VBA - add Outlook default signature

Danny_S_

New Member
Joined
Mar 27, 2018
Messages
8
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!

Code:
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
 

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
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.

Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,897
Messages
6,175,270
Members
452,628
Latest member
dd2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top