I have built a script that uses a mail list to create individual emails with individual attachments then I manually hit send once I've confirmed the attachment is correct/has been added.
I am hoping to automate the sending once the script has confirmed that the email attachment WAS added correctly.
The issue I have been running into is as follows.
When I run the script, (which I have added an if statement confirming attachment added), the email is sent (in a testing environment), even if the attachment was not added correctly.
I believe this is because the If statement only checks if the MailObj includes a filename, but not if that file actually exists and has been attached to the draft email. Unfortunately, in my use case, it would be almost pointless if I had to add each of the filenames manually for the mail merge, and as such my Mail Merge excel sheet currently automates the filename based upon a convention I will not change. Therefore the cells are populated with a set string which may or may not ACTUALLY link to a file.
I also want the emails that fail to add the attachment to still be created, but not sent so I can debug why the attachment failed.
Here is my script:
Sub emailMergeWithAttachments()
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim strBody As String
Dim rowCount As Integer
Dim i As Integer
Dim testing As Boolean
Dim mailsCreated As Integer
Dim mailsSent As Integer
mailsCreated = 0
mailsSent = 0
testing = True
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Activate
rowCount = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
For i = 2 To rowCount
If ws.Cells(i, 4) Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strBody = "Hi " & ws.Cells(i, 1) & _
",<p>Please find attached last fortnights Performance Report." & _
"<p>If you have any issues or questions please reach out via Email."
On Error Resume Next
With OutMail
.To = ws.Cells(i, 3).Text
.CC = ""
.BCC = ""
.Subject = "Individual Performance Report"
.Display
.HTMLBody = strBody & .HTMLBody
.Attachments.Add ws.Cells(i, 5).Text
If .Attachments.Count > 0 Then
.Send
mailsSent = mailsSent + 1
End If
mailsCreated = mailsCreated + 1
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
If testing Then Exit For
End If
Next i
MsgBox (mailsCreated & " emails Created" & vbNewLine & _
mailsSent & " emails Sent")
End Sub
Am I barking up the wrong tree?
I have built a script that uses a mail list to create individual emails with individual attachments then I manually hit send once I've confirmed the attachment is correct/has been added.
I am hoping to automate the sending once the script has confirmed that the email attachment WAS added correctly.
The issue I have been running into is as follows.
When I run the script, (which I have added an if statement confirming attachment added), the email is sent (in a testing environment), even if the attachment was not added correctly.
I believe this is because the If statement only checks if the MailObj includes a filename, but not if that file actually exists and has been attached to the draft email. Unfortunately, in my use case, it would be almost pointless if I had to add each of the filenames manually for the mail merge, and as such my Mail Merge excel sheet currently automates the filename based upon a convention I will not change. Therefore the cells are populated with a set string which may or may not ACTUALLY link to a file.
I also want the emails that fail to add the attachment to still be created, but not sent so I can debug why the attachment failed.
Here is my script:
Sub emailMergeWithAttachments()
Dim OutApp As Object
Dim OutMail As Object
Dim ws As Worksheet
Dim strBody As String
Dim rowCount As Integer
Dim i As Integer
Dim testing As Boolean
Dim mailsCreated As Integer
Dim mailsSent As Integer
mailsCreated = 0
mailsSent = 0
testing = True
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Activate
rowCount = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
For i = 2 To rowCount
If ws.Cells(i, 4) Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strBody = "Hi " & ws.Cells(i, 1) & _
",<p>Please find attached last fortnights Performance Report." & _
"<p>If you have any issues or questions please reach out via Email."
On Error Resume Next
With OutMail
.To = ws.Cells(i, 3).Text
.CC = ""
.BCC = ""
.Subject = "Individual Performance Report"
.Display
.HTMLBody = strBody & .HTMLBody
.Attachments.Add ws.Cells(i, 5).Text
If .Attachments.Count > 0 Then
.Send
mailsSent = mailsSent + 1
End If
mailsCreated = mailsCreated + 1
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
If testing Then Exit For
End If
Next i
MsgBox (mailsCreated & " emails Created" & vbNewLine & _
mailsSent & " emails Sent")
End Sub
Am I barking up the wrong tree?
Share asked Mar 28 at 3:15 mistamadd001mistamadd001 311 silver badge3 bronze badges 03 Answers
Reset to default 1When I run the script, ..., the email is sent (in a testing environment), even if the attachment was not added correctly.
I would consider that a bug in this API if it is not reporting an error if it is unable to process the requested file.
On the other hand, your code is using On Error Resume Next to ignore any error that happens to be raised. Try using On Error Goto ... with an actual error handler, and then see if you are getting a real error reported.
the If statement only checks if the MailObj includes a filename, but not if that file actually exists
That is correct. The attachment file is not processed until the email is saved or sent.
the cells are populated with a set string which may or may not ACTUALLY link to a file
Then you should check the file's existence yourself, using FileSystemObject.FileExists(). But, that is still no guarantee that the file can actually be accessed successfully when needed, even if it does exist.
I also want the emails that fail to add the attachment to still be created, but not sent so I can debug why the attachment failed.
Fix your error handling, and then that will likely work as intended.
Firstly, do not use On Error Resume Next - hiding a problem is not the same as fixing it.
Check if the file exist before adding it. Change the lines
.Attachments.Add filePath
.Send
mailsSent = mailsSent + 1
mailsCreated = mailsCreated + 1
to
If Dir(filePath) <> "" Then
' If file exists, add attachment and send
.Attachments.Add filePath
If .Attachments.Count > 0 Then
.Send
mailsSent = mailsSent + 1
End If
Else
' If file does not exist, show a message box
MsgBox "The file at " & filePath & " does not exist.", vbExclamation, "File Not Found"
End If
Instead of relying on .Attachments.Count, you should explicitly check if the file exists before adding it.
Replace your code between the On Error Resume Next and On Error GoTo 0 with the code given below:
On Error Resume Next
Dim filePath As String
filePath = ws.Cells(i, 5).Text ' Get the file path from the cell
If filePath <> "" And Dir(filePath) <> "" Then ' Check if the file path is not empty and exists
With OutMail
.To = ws.Cells(i, 3).Text
.CC = ""
.BCC = ""
.Subject = "Individual Performance Report"
.Display
.HTMLBody = strBody & .HTMLBody
.Attachments.Add filePath
.Send
mailsSent = mailsSent + 1
mailsCreated = mailsCreated + 1
End With
Else
With OutMail
.To = ws.Cells(i, 3).Text
.CC = ""
.BCC = ""
.Subject = "Individual Performance Report"
.HTMLBody = strBody & .HTMLBody
.Display ' Just display if no attachment
mailsCreated = mailsCreated + 1
End With
End If
On Error GoTo 0
This code will explicitly check the filepath <> "" and dir(filepath) <> "" ensuring the email is only sent if if an actual file exists. If the filepath is empty (""), then email will only be displayed and not sent.