Option Explicit Sub create_and_email_pdf() ' Author - Philip Treacy :: http://www.linkedin.com/in/philiptreacy ' http://www.MyOnlineTrainingHub.com/vba-to-create-pdf-from-excel-worksheet-then-email-it-with-outlook ' Date - 14 Oct 2013 ' Create a PDF from the current sheet and email it as an attachment through Outlook Dim EmailSubject As String, EmailSignature As String Dim CurrentMonth As String, DestFolder As String, PDFFile As String Dim Email_To As String, Email_CC As String, Email_BCC As String Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean Dim OverwritePDF As VbMsgBoxResult Dim OutlookApp As Object, OutlookMail As Object CurrentMonth = "" ' ***************************************************** ' ***** You Can Change These Variables ********* EmailSubject = "Invoice Attached for " 'Change this to change the subject of the email. The current month is added to end of subj line OpenPDFAfterCreating = False 'Change this if you want to open the PDF after creating it : TRUE or FALSE AlwaysOverwritePDF = False 'Change this if you always want to overwrite a PDF that already exists :TRUE or FALSE DisplayEmail = True 'Change this if you don't want to display the email before sending. Note, you must have a TO email address specified for this to work Email_To = "" 'Change this if you want to specify To email e.g. ActiveSheet.Range("H1") to get email from cell H1 Email_CC = "" Email_BCC = "" ' ****************************************************** 'Prompt for file destination With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then DestFolder = .SelectedItems(1) Else MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder" Exit Sub End If End With 'Current month/year stored in H6 (this is a merged cell) CurrentMonth = Mid(ActiveSheet.Range("H6").Value, InStr(1, ActiveSheet.Range("H6").Value, " ") + 1) 'Create new PDF file name including path and file extension PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _ & "_" & CurrentMonth & ".pdf" 'If the PDF already exists If Len(Dir(PDFFile)) > 0 Then If AlwaysOverwritePDF = False Then OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists") On Error Resume Next 'If you want to overwrite the file then delete the current one If OverwritePDF = vbYes Then Kill PDFFile Else MsgBox "OK then, 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 Else On Error Resume Next Kill PDFFile 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 'Create the PDF ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ :=False, OpenAfterPublish:=OpenPDFAfterCreating 'Create an Outlook object and new mail message Set OutlookApp = CreateObject("Outlook.Application") Set OutlookMail = OutlookApp.CreateItem(0) 'Display email and specify To, Subject, etc With OutlookMail .Display .To = Email_To .CC = Email_CC .BCC = Email_BCC .Subject = EmailSubject & CurrentMonth .Attachments.Add PDFFile If DisplayEmail = False Then .Send End If End With End Sub