I've written vba to send out an emailed pdf report to a list of cardholders and save the pdf. Every cardholder on the drop down list will receive an attached pdf via email and the pdf will be saved to a location of choice on my computer. I ran into a problem with an extra pdf being saved as the date only, with a blank template. I'm assuming that the vba is creating a pdf file for the blank field I have from the drop down list.
Please see the code below:
Please see the code below:
VBA Code:
Sub EmailPDFtoALL()
' 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
Dim DVCell As Range
Dim InputRange As Range
Dim DV As Range
'Which cell has data validation
Set DVCell = ActiveSheet.Range("A7")
'Determine where validation comes from
Set InputRange = Evaluate(DVCell.Validation.Formula1)
'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
For Each DV In InputRange
DVCell = DV.Value
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & DV.Value & " " & Format(Date, "mm-d-yy") & ".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)
Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Set EItem = EApp.CreateItem(0)
'Display email and specify To, Subject, Body etc
With EItem
reportname = Range("A4")
.SentOnBehalfOfName = "abc@gmail.com"
.To = Range("D10")
.CC = Range("D26")
.BCC = Range("H26")
.Subject = reportname & " " & "(" & " " & Format(Date, "mm-d-yy") & ")"
'To break a single stmt into multiple lines use the underscore immediately preceded by a space and immediately followed by a line terminator like in the example below
.HTMLbody = "Dear Cardholder,<br/><br/>This is notice that you currently have a <b>past due</b> amount on your <b>Corporate Card</b>." _
& "Please review the attached report for details and notify your departmental liaison of your plan of action to resolve this issue within <b><u>two business days</b></u>." _
& "<br/><br/> <font color = red><b><i>If these items have already been processed, please advise and disregard this notice.</font color></b></i><br/><br/>Warm regards," _
& "<br><img src='C:\Users\lharr28\OneDrive - Emory University\Pictures\CLFSC Signature.jpg' 'height=200 width=300>"
.Display
.Attachments.Add PDFFile
'Add CLFSC signature as an attachment and to hide the image attachment (set the position argument to O) - when I do this it only does the cardholder selected and not the whole list
.Attachments.Add "C:\Users\lharr28\OneDrive - Emory University\Pictures\CLFSC Signature.jpg"
.Display
If DisplayEmail = False Then
.Send
End If
End With
Next DV
End Sub
VBA Code:
