Sub Send_Each_Sheet_As_Pdf_With_HTMLSignature()
' ZVI:2017-02-03 http://www.mrexcel.com/forum/excel-questions/710212-visual-basic-applications-code-convert-excel-pdf-email-attachment-post4637844.html
' --> User settings, change to suit
Const EmailCell = "C7" ' Cell with email
Const IsDisplay As Boolean = False ' Change to False to .Send instead of .Display
Const IsSilent As Boolean = True ' Change to True to Send without the confirmation MsgBox
' <-- End of settings
Dim IsCreated As Boolean
Dim TempPath As String, PdfFile As String, Signature As String, Message As String
Dim OutlApp As Object
Dim i As Long
Dim char As Variant
Dim Sh As Worksheet
' Use the already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
' Create new instance of Outlook aplication
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
On Error GoTo 0
' TEMP folder for PDF saving
TempPath = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\"
' Turn off the screen updating
Application.ScreenUpdating = False
' Main
For Each Sh In ActiveWorkbook.Worksheets
' Prepare PDF file name
Debug.Print Sh.Index, Sh.Name
PdfFile = Sh.Name
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next
PdfFile = Left(TempPath & PdfFile, 251) & ".pdf"
' Try to delete temporary PDF file
If Len(Dir(PdfFile)) Then Kill PdfFile
' Export the selected sheets as PDF to the temporary folder
'Sh.Select
Sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
' Prepare email with PDF attachment and the default signature
With OutlApp.CreateItem(0)
' Add the attachment first for correct attachment's name with non English symbols
.Attachments.Add PdfFile
' Get default email signature without blinking (instead of .Display method)
With .GetInspector: End With
Signature = .HTMLBody
' Prepare e-mail (uncommenmt and fill the lines below)
.Subject = "Personal Report"
.To = Sh.Range(EmailCell).Value
.CC = ""
Message = "Dear " & Sh.Name & "," & vbLf & vbLf _
& "Please find the latest report attached"
.HTMLBody = Replace(Message, vbLf, Chr(60) & "br" & Chr(62)) & Signature
' Try to send or just display the e-mail
On Error Resume Next
If IsDisplay Then .Display Else .Send
' Show error of .Send method
If Not IsDisplay Then
' Return focus to Excel's window
Application.Visible = True
' Report on error or success
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
' Delete the temporary PDF file
If Len(Dir(PdfFile)) Then Kill PdfFile
End With
Next
' Restore screen updating
Application.ScreenUpdating = True
' 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
.
