Add default Outlook signature (HTML) to email

[Cratchie]

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

[gmayor]

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


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