[AccessD] How to send Automated E-mails from Access after hours

Bill Benson (vbacreations) vbacreations at gmail.com
Wed Jun 9 22:48:05 CDT 2010


You didn't ask but... some examples with 2 web-based "no cost" SMTP servers,
plus Road runner: just set up a don't-care-about-spam account and hard code
the password instead of parameter, for google and yahoo. Road runner, well,
of course that is a paid service. I also have code that works for a GE
server but of course that smtp server will not serve the public.

Sub Yahoo(FilPath as string, recipientlist as string, MyPassword as string,
mailid as string, SomeMessage as string, Somesubject as string)
Dim Password As String, UserName As String
Dim iMsg, iConf, Flds

On Error Resume Next
UserName = mailid
Password = MyPassword

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.mail.yahoo.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = left(mailid,instr(mailid,"@")-1)
Flds.Item(schema & "sendpassword") = Password
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
.To = recipientlist
.From = "<" & UserName & ">"
  .TextBody = SomeMessage
  .Subject = Somesubject
'.HTMLBody = Message
'.Sender = "Myname"
'.Organization = "Myname"
'.ReplyTo = "myemail at mydomain.com"
  .AddAttachment FilPath
  End If
  Set .Configuration = iConf
  Err.Clear
  .send
  If Err.Number <> 0 Then _
	'write an error log to a text file?
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing

End Sub


'You will have to modify this to hard code the parameters - just showing you
the serverports and config settings


Sub Google()
Dim Password As String, UserName As String
Dim iMsg, iConf, Flds

On Error Resume Next
UserName = InputBox("E-Mail Address to send from?", "Enter Sender's e-Mail
Address", GetSetting(ThisWorkbook.Name, "UserInfo", "GmailUserName",
"someone at Gmail.com"))
Password = InputBox("E-Mail Password?", "Enter Password",
GetSetting(ThisWorkbook.Name, "UserInfo", "GmailPassword",
"MyGmailAcctPassword"))

SaveSetting ThisWorkbook.Name, "UserInfo", "GmailUserName", UserName
SaveSetting ThisWorkbook.Name, "UserInfo", "GmailPassword", Password


Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

' send one copy with Google SMTP server (with autentication)
schema = "http://schemas.microsoft.com/cdo/configuration/"
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = UserName
Flds.Item(schema & "sendpassword") = Password
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

With iMsg
  .To = [sendto]
  .From = "<" & UserName & ">"
  .TextBody = Range("MyMessage").Cells(1)
  .Subject = Range("Mysubject").Cells(1)
  '.HTMLBody = Message
  '.Sender = "Myname"
  '.Organization = "Myname"
  '.ReplyTo = "myemail at mydomain.com"
  If [SendAttachment] = "Yes" Then
    Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name
    ThisWorkbook.SaveCopyAs Environ("Temp") & "\Test_" & ThisWorkbook.Name
    .AddAttachment Environ("Temp") & "\Test_" & ThisWorkbook.Name
  End If
  Set .Configuration = iConf
  Err.Clear
  .send
  If Err.Number <> 0 Then MsgBox "There was an error:" & Chr(13) & Chr(13) &
Err.Description
  If [SendAttachment] = "Yes" Then
    Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name
  End If
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Sub
Sub RoadRunnerSecure()
Dim Password As String, UserName As String
Dim iMsg, iConf, Flds

On Error Resume Next
UserName = InputBox("E-Mail Address to send from?", "Enter Sender's Road
Runner e-Mail Address", GetSetting(ThisWorkbook.Name, "UserInfo",
"RRUserName", "someone at nycap.rr.com"))

SaveSetting ThisWorkbook.Name, "UserInfo", "RRSecureUserName", UserName


Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
schema = "http://schemas.microsoft.com/cdo/configuration/"

Flds.Item(schema & "sendusing") = 2
'Flds.Item(schema & "smtpserverport") = 25
Flds.Item(schema & "smtpserver") = "smtp-server.nycap.rr.com"
Flds.Item(schema & "smtpserverport") = 587
Flds.Item(schema & "smtpauthenticate") = 1

UserName = "wbenson1 at nycap.rr.com"
UserName = "wbenson1"
Password = "Trigger1"
Flds.Item(schema & "sendusername") = UserName
Flds.Item(schema & "sendpassword") = Password
Flds.Item(schema & "smtpusessl") = 1
Flds.Update


'schema = "http://schemas.microsoft.com/cdo/configuration/"

With iMsg
  Set .Configuration = iConf
  .To = [sendto]
  .From = "<" & UserName & ">"
  .TextBody = Range("MyMessage").Cells(1)
  .Subject = Range("Mysubject").Cells(1)
  '.HTMLBody = Message
  '.Sender = "Myname"
  '.Organization = "Myname"
  '.ReplyTo = "myemail at mydomain.com"
  If [SendAttachment] = "Yes" Then
    Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name
    ThisWorkbook.SaveCopyAs Environ("Temp") & "\Test_" & ThisWorkbook.Name
    .AddAttachment Environ("Temp") & "\Test_" & ThisWorkbook.Name
  End If
  Set .Configuration = iConf
  Err.Clear
  .send
  If Err.Number <> 0 Then MsgBox "There was an error:" & Chr(13) & Chr(13) &
Err.Description
  If [SendAttachment] = "Yes" Then
    Kill Environ("Temp") & "\Test_" & ThisWorkbook.Name
  End If
End With

Set iMsg = Nothing
Set Flds = Nothing
Set iConf = Nothing

End Sub
 




More information about the AccessD mailing list