VBA - add Outlook default signature

[Danny_S_]

Been Looking around a way to avoid using HTMLbody as at work we have different signatures with different images and disclaimers. Everyone has their own signature set up using outlooks default tool. Is there anyway I can get the users own default signature added to this code in outlook without manually building a bunch of HTML signatures? Currently in outlook when we generate a new email the signature appears as default but using the below code removes it.

Thanks!

Sub Saveaspdfandsend()
Dim xSht As Worksheet
Dim xFile As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range


Set xSht = ActiveSheet
fNme = xSht.Range("A44").Value


xFile = "S:\Folder1\Folder2" & "\" & fNme & ".pdf"


'Check if file already exist
If Len(Dir(xFile)) > 0 Then
xYesorNo = MsgBox(xFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFile
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If


Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFile, Quality:=xlQualityStandard


'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.to = Range("Sheet2!B7").Value
.CC = "Address@place.com"
.Subject = "Invoice " & Range("A44").Value
.Body = "Good " & Range("Sheet2!C3") & "," & vbNewLine & vbNewLine & "Please find enclosed invoice relating to Claim Number " & Range("B14").Value & " for your attention." & vbNewLine & vbNewLine & "Should you have any queries about this please contact me on the details below." & vbNewLine & vbNewLine
.Attachments.Add xFile
If DisplayEmail = False Then
'.Send
End If
End With
Else
MsgBox "The active worksheet cannot be blank"
Exit Sub
End If
End Sub

 

[John_w]

See if you can adapt or incorporate this code into your code.

Note - the forum renders HTML tags embedded in code, losing the original HTML. To prevent this I've had to change "<" to "[" and ">" to "]" where a tag is specified and use Replace to get the proper HTML.

Public Sub Outlook_Email_With_Signature()

    Dim oApp As Object
    Dim oMail As Object
    Dim p1 As Long, p2 As Long
    Dim HTML As String, newHTML As String
    
    'Paragraphs to be inserted in email body text. Put each paragraph in a < p>...< /p> tag, and < br> tag for a new line within a paragraph.

    newHTML = ""
    newHTML = newHTML & "[p]First paragraph body text.
New line in first para.[/p]"
    newHTML = newHTML & "[p]Second paragraph body text here.[/p]"
    newHTML = newHTML & "[p]Third paragraph.[/p]"
    newHTML = Replace(newHTML, "[", "<")
    newHTML = Replace(newHTML, "]", ">")
    
    Set oApp = CreateObject("Outlook.Application")     
    Set oMail = oApp.CreateItem(0)  'olMailItem
    
    With oMail
        .GetInspector
        HTML = .HTMLbody
    End With
        
    'Find end of opening body tag and insert new HTML
    
    p1 = InStr(1, HTML, Replace("[body", "[", "<"), vbTextCompare)
    p1 = InStr(p1, HTML, ">")
    HTML = Left(HTML, p1) & newHTML & Mid(HTML, p1 + 1)
    
    With oMail
        .To = "email@address.com"
        .Subject = "Outlook email with automatic signature"
        '.Attachments.Add
        .HTMLbody = HTML
        '.Send
        .Display
    End With
    
    Set oMail = Nothing
    Set oApp = Nothing

End Sub