Adding Email Signature to current VBA Code

[RDPeach]

I need assistance in adding VBA code to existing code. The code I have captures excel information and converts to a BMP and pastes the info in to an email but the signature does not populate. The code is below:

Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Application.InputBox("Please select the data range:", "KuTools for Excel", Selection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createBmp(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.BMP'>" _
& "<br></font></span>"
With xOutMail
.Subject = "Carrier SL/ASA Alert"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.bmp", olByValue
.To = Range("AW1")
Cc = ""
.Display
End With
End Sub

Sub createBmp(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".bmp", "BMP"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

 

[John_w]

See if you can adapt this code for your situation. It creates an HTML email (as your code does) with the default signature.

Public Sub Create_Email_with_Signature()

    Dim OutApp As Object
    Dim OutEmail As Object
    Dim emailRange As Range
    Dim HTML As String
    Dim signature As String
    
    Set emailRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:C9")
    
    HTML = "<p>Dear Xxxx,</p><p>Excel cells are shown below.</p>" & _
           RangeToHTML(emailRange) & _
           "<p>Excel cells are shown above.</p>" & _
           "<p>Thanks.</p>"

    Application.ScreenUpdating = False
        
    Set OutApp = CreateObject("Outlook.Application")
    Set OutEmail = OutApp.CreateItem(0)
    
    With OutEmail
        .To = "address@email.com"
        .Subject = "Excel email"
        .Display
        signature = .HTMLBody
        .HTMLBody = HTML & signature
        .Display
    End With

    Application.ScreenUpdating = True
    
    Set OutEmail = Nothing
    Set OutApp = Nothing

End Sub


'https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
Function RangeToHTML(rng As Range)

' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim FSO As Object
    Dim ts As Object
    Dim tempFile As String
    Dim TempWB As Workbook

    tempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=tempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish True
    End With

    'Read all data from the htm file into RangetoHTML
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(tempFile).OpenAsTextStream(1, -2)
    RangeToHTML = ts.ReadAll
    ts.Close
    RangeToHTML = Replace(RangeToHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill tempFile

    Set ts = Nothing
    Set FSO = Nothing
    Set TempWB = Nothing
    
End Function

 

[RDPeach]

I don't think this will work because it is a set range and I need the input box to select as it is a dynamic selection and it needs to be exported as a BMP.

 

[John_w]

You need to adapt it to your requirements.

Simply replace the specific range with your code which allows the user to select the range.

Notice how the default signature is first read by creating an empty email and then it is appended to the HTML string to create the email body:

        .Display
        signature = .HTMLBody
        .HTMLBody = HTML & signature
        .Display

I've just realised you don't need the RangeToHTML call and routine, because your range is saved as an image, so that code can be deleted.