Add default Outlook signature (HTML) to email

Hi, I'm trying to add the outlook default signature to the email that I'm trying to create and everything I try if does not work. Can someone take a look at my code and let me know what code I need to add to get this work?


Private Sub CommandButton1_Click()
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 createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & ""
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hi Jo," _
& "<br>" _
& "<br>" _
& "Below are the numbers for today. Let me know if you have any questions." _
& "<br>" _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>" _
& "<br>Thanks,</font></span>"


With xOutMail
.Subject = "MONEY FOR " & Format(Date, "MM/DD/YYYY")
.Htmlbody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = ""
.Cc = ""
'.Bcc = ""
.Display
End With
End Sub
Sub createJpg(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 & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count ).Delete
Set xRgPic = Nothing
End Sub

If you use the Outlook Word Editor as follows to create the message the default signature is retained and you process the message body as if working in Word from VBA.
You will need to add the code function to start Outlook as indicated

Code:

---

Private Sub CommandButton1_Click()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng 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 = OutlookApp() 'requires code from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to start Outlook correctly
   
    Set xOutMail = xOutApp.CreateItem(0)
    With xOutMail
        Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
        TempFilePath = Environ$("temp") & "\"
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor    'access the message body for editing
        .To = ""
        .Cc = ""
        '.Bcc = ""
        .Subject = "MONEY FOR " & Format(Date, "MM/DD/YYYY")
        .Attachments.Add TempFilePath & "DashboardFile.jpg", 1
        .Display
        Set oRng = wdDoc.Range
        oRng.Collapse 1
        oRng.Text = "Hi Jo," & vbCr & vbCr & "Below are the numbers for today. Let me know if you have any questions." & vbCr & vbCr
        oRng.Collapse 0
        wdDoc.InlineShapes.AddPicture FileName:=TempFilePath & "DashboardFile.jpg", Range:=oRng
        oRng.End = oRng.End + 1
        oRng.Collapse 0
        oRng.Text = vbCr & vbCr & "Thanks," & vbCr
    End With
End Sub

---