Macro to paste in outlook but keep the default signature

[mikeellinas]

I use the following code to copy a range of cells and paste it as an image into a new email:

Sub Email()

'Copy range of interest
Dim r As Range
Set r = Range("A1:E24")
r.Copy
'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
With outMail
.CC = "xxxxxxxx"
.Subject = "xxxxxxxxxxxx"
End With

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture
With wordDoc.InlineShapes(1)
.LockAspectRatio = msoFalse
.Height = 7.29 * 50
.Width = 15.28 * 50
End With

End Sub

The problem is that when I do this, the default signature for new emails disappears. I cannot hard code my email signature in because I will have multiple users using the macro and each has a unique signature. That's why I want to keep the default signature for new emails.

Can anyone help with this?

 

[Worf]

Hello

Sub Mail_Outlook_Body()
Dim r2 As Range, wordDoc As Document, OutApp As Object, OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    Set wordDoc = OutMail.GetInspector.WordEditor
    .To = "example@test.com"
    .Subject = "test"
    .HTMLBody = " " & .HTMLBody
    Set r2 = Sheets("test").[A5:J22]
    r2.CopyPicture Format:=xlPicture
    .Display
    wordDoc.Application.ActiveDocument.Characters(1).Select
    With wordDoc.Application.Selection
        .End = .Start
        .Paste
    End With
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub