Add Signature to Email Created with VBA in Excel

[Michael515]

Hi Y'all,

With the help of Ron de Bruin's templates, I've pieced together this vba code to create an email with an attachment from an excel document, and now I want to add a signature to it. I keep getting a compile error around the GetBoiler(SigString) part of the code, and I can't quite seem to figure out why. Probably an easy fix I am not seeing. Here's my code, let me know what y'all think. Thanks ahead of time for all the help!

Also if anyone knows how to password protect the created attachment, mapping the password to a cell in the "Email" sheet that would be awesome too

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim EmailCc As String
    Dim EmailBcc As String
    Dim EmailSubject As String
    Dim EmailAttachment As String
    Dim EmailBody As String
    Dim EmailDlist As String
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
 
    EmailTo = Sheets("Email").Range("B2")
    EmailCc = Sheets("Email").Range("B3")
    EmailBcc = Sheets("Email").Range("B4")
    EmailSubject = Sheets("Email").Range("B5")
    EmailAttachment = Sheets("Email").Range("B6")
    EmailBody = Sheets("Email").Range("B7")
    SigName = Sheets("Email").Range("B9")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Sourcewb = ActiveWorkbook
    'Copy the ActiveSheet to a new workbook
    Sheets("Sheet1").Copy
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = EmailAttachment
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
       
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures" & SigName & ".htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
        On Error Resume Next
        With OutMail
            .to = EmailTo
            .CC = EmailCc
            .BCC = EmailBcc
            .Subject = EmailSubject
            .Body = EmailBody & "
" & Signature
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[Michael M]

Are you using the GetBoiler function provided on Rons Site ???

Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

 

[Michael515]

Ah I did not, I have added it back in but it still does not pull my signature. Is there any way to see the exact file path to make sure I am calling it correctly?

Also I noticed when I use

    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"

instead of

    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".html"

The body of the email contains all the specifications of the email in code format (after the designated body). For example at the end of the email I get:

><html xmlns="urn:schemas-microsoft-comfficeffice"
xmlns:w="urn:schemas-microsoft-comffice:word"
xmlns:m="http://schemas.microsoft.com/office/2004/12/omml"
xmlns="HTML 4.01 Specification">
<head>
****** http-equiv=Content-Type content="text/html; charset=windows-1252">
****** name=ProgId content=Word.Document>
****** name=Generator content="Microsoft Word 14">
****** name=Originator content="Microsoft Word 14">

Any thoughts to why that is happening as well? Again happens when it is set to .htm instead of .html

 

[Michael M]

Add a line to this section

SigString = Environ("appdata") & _
                "\Microsoft\Signatures" & SigName & ".htm"

To

SigString = Environ("appdata") & _
                "\Microsoft\Signatures" & SigName & ".html"
msgbox SigString

The msgbox should show what the sigstring variable is !!

As long as you use either HTML or HTM consistently throughout the code, it don't believe it should make any difference

 

[Michael515]

I made changes to the code and have it working now despite one issue. The body of the email is referencing a cell in the "Email" sheet, as you can see by the Dim variable. When the email is created, the body doesn't reflect the cell exactly, i.e. the cell has line breaks (by pressing alt-enter) but the email doesn't reflect those line breaks, and just pastes the body as one complete line. So instead of being:

Hi there,

blah blah blah

Thanks

It is reflected as;

Hi there, blah blah blah, thanks

One line instead of three.

I have attached the code below, let me know if you see any changes I can make:

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim EmailCc As String
    Dim EmailBcc As String
    Dim EmailSubject As String
    Dim EmailAttachment As String
    Dim EmailBody As String
    Dim EmailDlist As String
    Dim Signature As String
 
    EmailTo = Sheets("Email").Range("B2")
    EmailCc = Sheets("Email").Range("B3")
    EmailBcc = Sheets("Email").Range("B4")
    EmailSubject = Sheets("Email").Range("B5")
    EmailAttachment = Sheets("Email").Range("B6")
    EmailBody = Sheets("Email").Range("B7")

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set Sourcewb = ActiveWorkbook
    'Copy the ActiveSheet to a new workbook
    Sheets("Sheet5").Copy
    Set Destwb = ActiveWorkbook
    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2016
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False
    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & ""
    TempFileName = EmailAttachment
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
    .Display
    End With
    Signature = OutMail.htmlbody
       
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .to = EmailTo
            .CC = EmailCc
            .BCC = EmailBcc
            .Subject = EmailSubject
            .htmlbody = EmailBody & vbNewLine & Signature
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Display
        End With
        On Error GoTo 0
        .Close savechanges:=False
    End With
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub