How to fix VBA code to stop saving and emailing PDF of blank cell from data validation list?

[lharr28]

I created a delinquency notice template that sends a pdf to each cardholder on the drop-down list. The pdf is saved to the location you choose. I ran into a problem with the macros saving an empty copy of the template with just the date and populating a blank outlook email as well to be sent. When the macros finished running I got the following error:

Any help would be appreciated! Here's the code I used:

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,"


.Attachments.Add PDFFile
.Display

If DisplayEmail = False Then

.Send

End If

End With

Next DV

End Sub

 

[ranman256]

check if cell is valid, then send

'Display email and specify To, Subject, Body etc
With EItem

    reportname = Range("A4")
    
    .SentOnBehalfOfName = "abc@gmail.com"
    
      'no primary email, then exit
    If Range("D10") = "" Then Exit Sub
    
    .To = Range("D10")
    If Range("D26") <> "" Then .CC = Range("D26")
    If Range("H26") <> "" Then .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,"
    
    
    .Attachments.Add PDFFile
    .Display
    
    If DisplayEmail = False Then .Send
End With

 

[lharr28]

Thanks for your help! I tried this but it is still giving me the same debug message. I have an email address in that field. Can you explain why?