Private Sub btnSendEmail_Click()
'Code to add signature to email
'[URL unfurl="true"]http://www.rondebruin.nl/win/s1/outlook/signature.htm[/URL]
'20160826
Dim objOutlook As Object 'Use for late binding
Dim objNameSpace As Object 'Use for late binding
Dim MailOutLook As Object 'Use for late binding
Dim stBody As String
Dim SigString As String
Dim Signature As String
Dim stCC As String
Dim stSubject As String
Dim stsql As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim yesno
'Check if should send an email if an email was previously sent
'for this document number
stlogdate = DMax("sentdate", "tblEmailLog", "documentnumber='" & Forms!frm.DocumentNumber & "'")
If Not IsNull(stlogdate) Then
yesno = MsgBox("An email for " & Me.txtDocumentNumber & " was already sent on " & stlogdate & ". Would you like to send a new email? " & vbCrLf & vbCrLf, vbYesNo + vbQuestion, "Previously Emailed")
If yesno = vbNo Then
MsgBox "Email cancelled.", vbOKOnly + vbInformation, "Email Aborted"
GoTo Finished
End If
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("tblEMailLog")
'*************************************************
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
'*****************************************************
Set MailOutLook = objOutlook.CreateItem(0) 'Late binding method
stSubject = Me.txtUCASEFilename
stBody = "Hi " & ",<br><br>" & _
"I am assisting in uploading the drawings and " & _
"would like to know how to handle the drawings based on the comment " & _
"file that indicate XXX on the attached file. <br><br>" & _
"Please let me know when you have a chance.<br><br> " & _
"Thanks,<br>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\MySig.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With MailOutLook
.BodyFormat = 3 'Late binding in lieu of olFormatRichText
.To = ConcatRelated("email", "tblEmail", "distributiontype='To'", , ";") '"YourEmail@Email.com"
.CC = ConcatRelated("email", "tblEmail", "distributiontype='cc'", , ";")
'.bcc = ""
.Subject = stSubject 'Me.txtUCASEFilename
.HTMLBody = stBody & "<br>" & Signature
'.Send
.Display 'Use for testing in lieu of .Send
End With
On Error GoTo 0
'Add record to email log
rs.AddNew
rs!DocumentNumber = Me.DocumentNumber
rs!SentTo = ConcatRelated("FullName", "tblEmail", "distributiontype='To'", , "; ")
rs!SentDate = Now()
rs.Update
frmProCore_Sub.Requery
Finished:
Set MailOutLook = Nothing
Set objOutlook = Nothing
Set rs = Nothing
Set db = Nothing
End Sub
