Private Function Command67Send()
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
Dim sServer As String, sSenderEmail As String, sSenderPassword As String, sSendError 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, sbounce 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
On Error GoTo 0
If IsNull(Me.Body) Then 'to circumvent "Invalid null" error bomb out. Whoever sends an email with empty body?
Me.Body = "."
sBody = "."
Else
sBody = Me.Body
End If
sServer = Me.MoSender 'sender credentials picked up from registration file
sSenderEmail = Me.MoEmail
sSenderPassword = Me.MoPassword
sPort = Me.MoPort
sSSL = True
If Me.MoSSL = 0 Then sSSL = False
sAuth = True
If Me.MoAuth = 0 Then sAuth = False
Dim objMsg As Object
Dim objConf As Object
Dim objFlds As Object
Const cdoDSNDefault = 0 'None
Const cdoDSNNever = 1 'None
Const cdoDSNFailure = 2 'Failure
Const cdoDSNSuccess = 4 'Success
Const cdoDSNDelay = 8 'Delay
Const cdoDSNSuccessFailOrDelay = 14 '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") = sServer
.Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = sPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = sAuth
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = sSSL
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sSenderEmail
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sSenderPassword
.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")
snameKEEP = .Fields("namealpha")
mName = .Fields("propername")
sname = Mid$(sname, InStr(sname, ",") + 2)
sEmail = .Fields("emailaddr")
sbounce = Me.Mobounce
strbody = sBody
Dim strHTML
strHTML = "<FONT Face='Comic Sans MS' Size=3>Dear " & sname & ",<br><br>" & strbody & "</font>"
strHTML = strHTML & "</BODY></HTML>"
' sServer = Me.MoSender 'sender credentials picked up from registration file
' sSenderEmail = Me.MoEmail
' sFromField = Me.FromField Sender's name from email setup screen
' sReplytoEmailAddr = Me.ReplyToEmailAddr Reply to email addr from email setup screen
With objMsg
Set .Configuration = objConf
.To = sEmail
.from = sFromField & " <" & sReplytoEmailAddr & ">"
.sender = sReplytoEmailAddr
.ReplyTo = sReplytoEmailAddr
.Subject = sSubjectLine
.htmlbody = strHTML
On Error Resume Next
.Send
sSent = "Sent"
If err.Number <> 0 Then
sSent = "Failed" 'this is the log entry
messageTrigger = -1
.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("MemberName") = snameKEEP
.Fields("Attachment") = sAttachmentLocation
.Fields("Screen") = "Invites"
.Fields("EmailClient") = sSenderEmail
.Fields("smtp") = sServer
.Fields("usedSSL") = sSSL
.Fields("usedAUTH") = sAuth
.Fields("usedPort") = sPort
.Update
End With
If InStr("strbody", "transport") > 0 Then
MsgBox "Lost Transport connection--Press Send Email button again.", vbInformation, "Caution!"
GoTo results_Exit
End If
.MoveNext
Loop
End With
DoCmd.Close acForm, "EmailSetupJean", acSaveYes
results_Exit:
Set objMsg = Nothing
Set rstEmailLog = Nothing
Set rstSendinvites = Nothing
If messageTrigger Then
MsgBox "Check Email Log for Failed Email Addresses", vbInformation, "Caution!"
End If
DoCmd.Hourglass (0)
Exit Function
errRoutine:
If err = -2147024894 Then
MsgBox "The system cannot find the attachment file.", vbInformation, "Caution!"
Else
MsgBox Error$
End If
Resume results_Exit
End Function