Sub SendPDF_WithAccountSignatiure()
' --> User settings, change to suit
Const IsDisplay As Boolean = True ' Change to False for .Send instead of .Display
Const IsSilent As Boolean = False ' Change to True to show Send status
Const FontName = "Candara" ' Font name of the email body
Const FontSize = 11 ' Font size of the email body
Const Account = 2 ' Index or Name of the account to send from
' <-- End of the settings
Dim IsCreated As Boolean
Dim OutlApp As Object
Dim char As Variant
Dim PdfFile As String, HtmlFont As String, HtmlBody As String, HtmlSignature As String
' Edit the body's html text as required
' The tags are: h3 is for Header#3; b is for Bold; br is for line break
' HTML tag's are not displayed properly in the post of MrExcel forum, thus replacing is used to fix this problem
HtmlBody = "First line, (br)" _
& "Second line.(br)" _
& "Third line."
HtmlBody = Replace(HtmlBody, "(", "<")
HtmlBody = Replace(HtmlBody, ")", ">")
' Set the font for the html-body (parentheses are just because of MrExcel posting limitation)
HtmlFont = HtmlFont = "(body font: " & FontSize & "pt " & FontName & ";color:black"")"
HtmlFont = Replace(HtmlFont, "(", "<")
HtmlFont = Replace(HtmlFont, ")", ">")
' Define PDF filename
PdfFile = Range("H2") & "_" & ActiveSheet.Name
' Replace illegal symbols in PdfFile by underscore
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next
' Apply %TEMP% path to the file name and limit lenght of the pathname
PdfFile = Left(Environ("TEMP") & IIf(Right(Environ("TEMP"), 1) <> "\", "\", "") & PdfFile, 251) & ".pdf"
' Try to delete PDF file if present
If Len(Dir(PdfFile)) Then Kill PdfFile
' Export the activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use the already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare email with PDF attachment and the default signature
With OutlApp.CreateItem(0)
' Set HTML format
.BodyFormat = 2
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile
' Set the required account by const Account
Set .SendUsingAccount = OutlApp.Session.Accounts.Item(Account)
' Get default email signature without blinking (instead of .Display method)
With .GetInspector: End With
HtmlSignature = .HtmlBody
' Prepare e-mail
.Subject = Range("H2") & " / " & Range("K1")
.To = Range("L1") ' <-- Put email of the recipient here
.HtmlBody = HtmlFont & HtmlBody & HtmlSignature
' Try to send or just display the e-mail
On Error Resume Next
If IsDisplay Then .Display Else .Send
' Show error of the .Send method
If Not IsDisplay Then
' Return focus to Excel's window
Application.Visible = True
' Show error/success message
If Err Then
MsgBox "E-mail was not sent for some reasons" & vbLf & "Please check it", vbExclamation
.Display
Else
If Not IsSilent Then
MsgBox "E-mail successfully sent", vbInformation
End If
End If
End If
On Error GoTo 0
End With
' Delete the temporary PDF file
If Len(Dir(PdfFile)) Then Kill PdfFile
' Try to quit Outlook if it was not previously open
If IsCreated Then OutlApp.Quit
' Try to release the memory of object variable
Set OutlApp = Nothing
End Sub
