I built a script that uses a mail list to create individual emails with individual attachments.
I manually hit send once I've confirmed the attachment is correct/has been added.
I am hoping to automate the sending.
When I run the script, (in which I have added an If statement confirming the attachment was 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 checks if the MailObj includes a filename, not if that file exists and has been attached to the draft email.
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 automates the filename based upon a convention I will not change. Therefore the cells are populated with a set string which may not 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.
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
Your current code is rather messy. For example, you are creating a new instance of Outlook for every Iteration of the Loop — and not checking to see if Outlook is already open first!
You are also wrapping vast swathes of your code in "On Error Resume Next", which means that VBA will not alert you to any errors that occur.
Finally, you are checking if the Email has any attachments, rather than if it has the specific attachment that you are trying to send. If, for example, you have a default-signature set up which includes an image file, then that image will be a Hidden attachment (i.e. it has a Position of 0) that is referenced by CID. This will mean that Attachments.Count is greater than zero from the moment you .Display it, before you even attempt to attach the extra file.
The below code should fix many of those issues: for example, while it keeps the "Resume Next" error handling you were using (Although, I would recommend changing FailureMode to 2 while testing/debugging), it will output details of any errors encountered to the Immediate Window via Debug.Print (Meaning that you will, at least, know that an error did occur…). It checks to see if there is an Attachment on the Email with the same name as the one you are trying to attach. It uses a single Instance of Outlook for the entire Subroutine (if necessary) — and (if Outlook was not already open) closes it at the end (if all mails were sent successfully)
Sub emailMergeWithAttachments()
Const FailureMode AS Long = 0 '0: Resume Next; 1: Stop; 2: Ask; Other: End Subroutine
Dim ErrMsg As String, ErrAction As VbMsgBoxResult
Dim OutApp As Object, OutMail As Object, OutExisted As Boolean
Dim ws As Worksheet
Dim strBody As String
Dim rowCount As Integer
Dim i As Integer
Dim testing As Boolean
Dim mailsCreated As Long, mailsSent As Long
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
Dim AttachmentElement AS Attachment, AttachmentFileName AS String, IsAttached As Boolean
'Create the Outlook object once for the Sub, rather than once every iteration of the loop
On Error GoTo CreateApp
Set OutApp = GetObject(, "Outlook.Application") 'Get an open Outlook application
If OutApp Is Nothing Then GoTo CreateApp
OutExisted = True
GoTo AppExists
CreateApp: 'If there was not an open Outlook application
On Error GoTo -1
On Error GoTo 0
Set OutApp = CreateObject("Outlook.Application") 'Open a new Outlook application
OutExisted = False
AppExists:
DoEvents
On Error GoTo SubErr 'Error Handling is at the end of the Sub
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 OutMail = OutApp.CreateItem(0)
IsAttached = True
strBody = "Hi " & ws.Cells(i, 1) & _
",<p>Please find attached last fortnights Performance Report.</p>" & _
"<p>If you have any issues or questions please reach out via Email.</p>"
With OutMail
.To = ws.Cells(i, 3).Text
.CC = ""
.BCC = ""
.Subject = "Individual Performance Report"
.Display
.Recipients.ResolveAll
.HTMLBody = strBody & .HTMLBody
If ws.Cells(i, 5).Text <> vbNullString Then 'If an Attachment has been specified
IsAttached = False
If fso.FileExists(ws.Cells(i, 5).Text) Then 'And the File Exists
.Attachments.Add ws.Cells(i, 5).Text
AttachmentFileName = "\" & ws.Cells(i, 5).Text
AttachmentFileName = Mid(AttachmentFileName, InStrRev(AttachmentFileName,"\")+1) 'Get the intended FileName
DoEvents
If .Attachments.Count > 0 Then
For Each AttachmentElement In .Attachments
'Check to see if the specified file has been successfully attached
If AttachmentElement.FileName = AttachmentFileName Then
IsAttached = True
Exit For
End If
Next AttachmentElement
End If
End If
End If
mailsCreated = mailsCreated + 1
If IsAttached Then 'Doing things this way allows for us to check multiple attachments, such as embedding images
.Send
mailsSent = mailsSent + 1
End If
End With
If testing Then Exit For
End If
Next i
MsgBox (mailsCreated & " emails Created" & vbNewLine & _
mailsSent & " emails Sent")
CleanExit:
'Tidy up out objects
Set fso = Nothing
Set OutMail = Nothing
If Not (OutExisted Or OutApp Is Nothing Or mailsCreated<>mailsSent) Then OutApp.Quit 'If Outlook was opened by this Sub (i.e. it was not already open), then close it.
Set OutApp = Nothing
Set ws = Nothing
Exit Sub
SubErr:
'Capture and Reset Error
ErrMsg = "Error " & Err.Number & " | " & Err.Description
On Error GoTo -1
On Error GoTo SubErr
'Handle Error, according to FailureMode
Debug.Print Format(Now(),"yyyy-mm-dd hh:mm:ss") & " | " & ErrMsg
If FailureMode = 0 Then 'Ignore Error
ErrAction = vbIgnore
ElseIf FailureMode = 1 Then 'Stop
ErrAction = vbRetry
Stop
ElseIf FailureMode = 2 Then 'Ask what to do
ErrAction = MsgBox(Replace(ErrMsg," | ", vbCrLf, 1, 1),vbCritical + vbAbortRetryIgnore)
Else
ErrAction = vbAbort
End If
Select Case ErrAction
Case vbAbort:
GoTo CleanExit
Case vbRetry:
Resume
Case vbIgnore:
Resume Next
End Select
End Sub