This is a macro I made awile ago to send Excel data via Outlook
It has signature code that you might find useful
It's most likely not perfect ( )so if Graham has suggestions, I'll be glad to take them
' ver 03 10/26/2018
' added existance checks
' made into function, True if successful
' ver 02 10/25/2018
' added sSignatures
Option Explicit
Option Private Module
Const olFormatHTML As Long = 2
Const olFormatPlain As Long = 1
Const olFormatRichText As Long = 3
Const olFormatUnspecified As Long = 0
Const olAppointmentItem As Long = 1
Const olContactItem As Long = 2
Const olDistributionListItem As Long = 7
Const olJournalItem As Long = 4
Const olMailItem As Long = 0
Const olNoteItem As Long = 5
Const olPostItem As Long = 6
Const olTaskItem As Long = 3
Const sDefaultSignature As String = "My Sig.htm"
Dim sSignatureFolder As String, sSignatureFile As String
'Signatures stored in Environ("appdata") & "\Microsoft\Signatures\"
'If NO signature files, generate plain text email and plain text signature
'If 1 signature file, use the .HTM version as signature and generate HTML email
'if more than 1
' use "My Sig.htm" if avaialble
' otherwise generate plain text email and plain text signature
Function SendWithOutlook(emailRecipient As String, _
emailMessage As String, _
Optional emailSubject As String = vbNullString, _
Optional emailAttachmentFile As String = vbNullString) As Boolean
Dim oOutlook As Object
Dim oMailItem As Object
Dim sSignature As Variant
Dim MailFormat As Long
Dim sHtmlBody As String, sPlainBody As String
On Error GoTo EmailError
'see if attachment is there, raise error if not
If Len(emailAttachmentFile) > 0 Then
If Len(Dir(emailAttachmentFile)) = 0 Then Err.Raise vbObject + 1
End If
'see if Signature file is there, raise error if not
sSignatureFolder = Environ("appdata") & "\Microsoft\Signatures\"
If Len(Dir(sSignatureFolder)) = 0 Then Err.Raise vbObject + 2
'get sSignature as text or the count number if not exactly 1
sSignature = Sigs
If IsNumeric(sSignature) Then
If sSignature = 0 Then ' no sSignatures
MailFormat = olFormatPlain
Else 'if more than one, does default exist (My Sig.htm)
sSignatureFile = Dir(sSignatureFolder & sDefaultSignature)
If Len(sSignatureFile) = 0 Then ' if not, then plain text email
MailFormat = olFormatPlain
Else
MailFormat = olFormatHTML
End If
End If
Else
MailFormat = olFormatHTML
End If
'build signatures and format body as HTML or as Plain Text
If MailFormat = olFormatHTML Then
sSignature = CreateObject("Scripting.FileSystemObject").GetFile(sSignature).OpenAsTextStream(1, -2).readall
sHtmlBody = emailMessage & "<hr>Sent " & FormatDateTime(Now, vbLongDate) & " at " & FormatDateTime(Now, vbLongTime) & "<hr><br>"
sHtmlBody = Replace(sHtmlBody, "^", "<br>")
Else
sSignature = vbCrLf & vbCrLf & _
"--------------------------------------------------------------------------" & _
vbCrLf & vbCrLf & _
Application.UserName & _
vbCrLf & vbCrLf & _
"Sent " & FormatDateTime(Now, vbLongDate) & " at " & FormatDateTime(Now, vbLongTime)
sPlainBody = Replace(emailMessage, "^", vbCrLf)
End If
'Set Outlook to current instance, opening if necessary
Set oOutlook = GetObject(, "Outlook.Application")
'create new mail item
Set oMailItem = oOutlook.CreateItem(olMailItem)
With oMailItem
'Returns or sets a semicolon-delimited String list of display names for the To recipients for the Outlook item. Read/write.
.To = emailRecipient
.CC = vbNullString
.BCC = vbNullString
If Len(emailSubject) = 0 Then
.Subject = ThisWorkbook.Name & " -- " & Format(Now, "General Date")
Else
.Subject = emailSubject
End If
If MailFormat = olFormatHTML Then
.BodyFormat = MailFormat
.HtmlBody = sHtmlBody & sSignature
Else
.BodyFormat = MailFormat
.Body = sPlainBody & sSignature
End If
If Len(emailAttachmentFile) > 0 Then .Attachments.Add emailAttachmentFile
.readreceiptrequested = False
.Send
End With
On Error GoTo 0
Set oMailItem = Nothing
Set oOutlook = Nothing
SendWithOutlook = True
Exit Function
EmailError:
If Err.Number = 429 Then
Set oOutlook = CreateObject("Outlook.Application")
Resume Next
Else
SendWithOutlook = False
Set oMailItem = Nothing
Set oOutlook = Nothing
End If
End Function
'if only one sSignature then return the path, if 0 or more than 1, return the count
Function Sigs() As Variant
Dim N As Long
sSignatureFile = Dir(sSignatureFolder & "*.htm")
Do While Len(sSignatureFile) > 0
N = N + 1
sSignatureFile = Dir
Loop
If N = 1 Then
Sigs = sSignatureFolder & Dir(sSignatureFolder & "*.htm")
Else
Sigs = N
End If
End Function