[Sub Attach_Sheets_As_Pdf_With_Signature()
' ZVI:2016-09-20 [URL]http://www.mrexcel.com/forum/excel-questions/710212-visual-basic-applications-code-convert-excel-pdf-email-attachment-5.html#post4636678[/URL]
' --> User settings, change to suit
Const MySheets As Variant = "SUMMARY,PAYROLL,MILEAGE,OVERTIME" ' Use MySheets = 0 for all the sheets
Const IsDisplay As Boolean = True ' 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 PdfFile As String, Signature As String
Dim OutlApp As Object
Dim i As Long
Dim char As Variant
' Define PDF filename
PdfFile = ActiveWorkbook.Name
i = InStrRev(PdfFile, ".xl", , vbTextCompare)
If i > Len(PdfFile) - 5 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name
' Clean up the name of PDF file
For Each char In Split("? "" / \ < > * | :")
PdfFile = Replace(PdfFile, char, "_")
Next
' Add %TEMP% path to the file name and limit too long name
PdfFile = Left(CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "" & PdfFile, 251) & ".pdf"
' Try to delete PDF file for the case it was not deleted at debugging
If Len(Dir(PdfFile)) Then Kill PdfFile
' Select sheets to be exported in the PDF (single) file
If MySheets = 0 Then
' All sheets to PDF
Sheets.Select
Else
' Sheets listed in MySheets to PDF
Sheets(Split(MySheets, ",")).Select
End If
' Export the selected sheets as PDF to the temporary folder
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
.Select
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
On Error GoTo 0
' Prepare email with PDF attachment and 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 = .Body
' Prepare e-mail (uncommenmt and fill the lines below)
.Subject = "Payroll Monthly Analysis"
.To = Range("I3").Value
.CC = Range("I4").Value
.Body = "Hi," & vbLf & vbLf _
& "Please find the latest payroll report attached" & vbLf & vbLf _
& 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
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
/CODE]
Regards
Will
Once again any assistance is greatly appreciated!
