A couple of years ago, with your help, I got a vba cdo email sending routine working. My remaining problem: is it possible to get bounce messages to return to the sender's replytoaddress rather than the gmail.com account? There will be three people using this routine, and each of them really needs his own bounces. These three don't monitor the organization's gmail account (which I set up for this routine to use), and I don't want to be responsible for doing it myself for evermore.
The following is the cdo code I am using. The four lines commented out in the middle are lines I borrowed (unsuccessfully) from Microsoft. When I uncomment them, nothing gets sent, even test emails that work otherwise. What am I doing wrong?
Thank you for any insights.
The following is the cdo code I am using. The four lines commented out in the middle are lines I borrowed (unsuccessfully) from Microsoft. When I uncomment them, nothing gets sent, even test emails that work otherwise. What am I doing wrong?
Code:
Private Sub Command13_Click()
On Error GoTo errRoutine
Dim dbs As Database
Set dbs = CurrentDb()
Dim rstSendinvites As Recordset
Dim sname As String, sEmail As String, sinvitsentdate As String, sSent As String, sPS As Variant, mName As String
Dim iInvitsent As Integer, iSendinvite As Integer, jk As Integer
Set rstSendinvites = dbs.OpenRecordset("sendinvites", dbOpenDynaset)
DoCmd.Hourglass (-1)
Dim sFromField As String, sReplytoEmailAdd As String, sSubjectLine As String, _
sAttachmentLocation As String, sAttach As String, sBody As String, strbody As String
If Me.Dirty Then Me.Dirty = False 'force save current record
sFromField = Me.FromField
sReplytoEmailAddr = Me.ReplyToEmailAddr
sSubjectLine = Me.SubjectLine
If Not IsNull(Me.AttachmentLocation) Then sAttachmentLocation = Me.AttachmentLocation
If InStr(sAttachmentLocation, ";") > 0 Then
sAttach = Trim(Mid(sAttachmentLocation, InStr(sAttachmentLocation, ";") + 1))
sAttachmentLocation = Trim(Left(sAttachmentLocation, InStr(sAttachmentLocation, ";") - 1))
End If
sBody = Me.Body
Dim objMsg As Object
Dim objConf As Object
Dim objFlds As Object
'Const cdoSendUsingPickup = 1
'Const cdoSendUsingPort = 2
'Const cdoAnonymous = 0
'Const cdoBasic = 1 ' clear text
'Const cdoNTLM = 2 'NTLM
'Delivery Status Notifications
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const CDO_SUCCESS_FAIL_DELAY = 14 ' sends delivery receipt always 'Success, failure or delay''
Set objMsg = CreateObject("CDO.Message")
Set objConf = CreateObject("CDO.Configuration")
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xyz@gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "xxxx"
.Update
End With '
Dim messageTrigger As Integer
messageTrigger = 0
Dim rstEmailLog As Recordset
Set rstEmailLog = dbs.OpenRecordset("EmailLog", dbOpenDynaset)
With rstSendinvites
If Len(sAttachmentLocation) > 0 Then objMsg.Addattachment sAttachmentLocation
If Len(sAttach) > 0 Then objMsg.Addattachment sAttach 'add second attachment
Do While Not .EOF
sname = .Fields("namealpha")
mName = .Fields("propername")
sname = Mid$(sname, InStr(sname, ",") + 2)
sEmail = .Fields("emailaddr")
strbody = sBody
Dim strHTML
strHTML = "<FONT Face='Comic Sans MS' Size=3>Dear " & sname & ",<br><br>" & strbody & "</font>"
strHTML = strHTML & "</BODY></HTML>"
With objMsg
Set .Configuration = objConf
.To = sEmail
.from = sFromField & " <" & sReplytoEmailAddr & ">"
.ReplyTo = sReplytoEmailAddr
.Subject = sSubjectLine
.htmlbody = strHTML
If Len(Trim(Me.BCCField)) > 0 Then
.BCC = Me.BCCField
End If
' .Fields("urn:schemas:mailheader:disposition-notification-to") = sReplytoEmailAddr
' .DSNOptions = cdoDSNFailure
' .DSNOptions = 2
' .Fields.Update
On Error Resume Next
.Send
sSent = "Sent"
If err.Number <> 0 Then 'this sends immediate failure notice
sSent = "Failed" 'this is the log entry 'when discernible, such as lost
messageTrigger = -1 'transport problem.
.To = Me.ReplyToEmailAddr
.Subject = "Delivery Failure to " & mName
.htmlbody = "Email to " & mName & " Failed: " & Error$
strHTML = "Email to " & mName & " Failed: " & Error$
.Send
On Error GoTo errRoutine
GoTo skipper 'skip record update to uncheck sendemail box
End If
On Error GoTo errRoutine
End With
.Edit
.Fields("sendemail") = 0
.Update
skipper: With rstEmailLog
.AddNew
.Fields("FromField") = sFromField
.Fields("Sent") = sSent
.Fields("ReplyToaddr") = sReplytoEmailAddr
.Fields("SendToaddr") = sEmail
.Fields("SubjField") = sSubjectLine
.Fields("BodyField") = strHTML
.Fields("BCCaddr") = Me.BCCField
.Fields("logtimestamp") = Now()
.Fields("MemberName") = sname
.Fields("Attachment") = sAttachmentLocation
.Fields("Screen") = "Invites"
.Fields("EmailClient") = "xyz@gmail.com"
.Update
End With
.MoveNext
Loop
End With
DoCmd.Close acForm, "EmailSetup", acSaveYesThank you for any insights.