Send Outlook Emails with Multiple Attachments using Excel VBA

Home

Note: This webpage is designed to accompany the Youtube video posted above. The video offers detailed explanation on all topics; while this webpage will serve as a repository for the code presented in the video.

In this session,
• We will look at a simple example where we create just one email with multiple attachments.
• Next, we will look at a more complex example where we will send multiple emails with multiple attachments each. We will use Advanced Filters through VBA in this example, which should be interesting.

Example 1: Send Multiple Attachments in a Single Email

Here, we will loop through a set of files and send it to the customer i.e. one single recipient. Main point here is loading all the file names into a string, populating an array from that string using the Split() function and passing the array as a parameter into our Send Email sub procedure.

We will build on this code in the next example.

Option Explicit

Const sFolderPath As String = "C:\Youtube\Outlook Tutorial 01\Outlook\Invoices\"

' Define Body
Const emBody As String = "Hi There,<br><br>" & _
            "Please find your outstanding invoices attached.<br><br>" & _
            "Regards,<br>" & _
            "OSA Team"
                    
' Define Subject
Const emSubject As String = "Overdue Invoices - Food Jar Co"


Sub Send_Multiple_Emails_Basic_Example()
Dim sInvoice As String, emAttach As String, arrAttach() As String, sFileName As String
Dim lrow As Long
Dim i As Long

lrow = wsSingle.Range("a1").CurrentRegion.Rows.Count

For i = 2 To lrow
    sInvoice = wsSingle.Range("A" & i).Value
    sFileName = sFolderPath & sInvoice & ".pdf"
    emAttach = emAttach & sFileName & ","
Next i
emAttach = Left(emAttach, Len(emAttach) - 1)
arrAttach = Split(emAttach, ",")

Send_Email arrAttach
End Sub


Function Send_Email(sfAttach() As String) As Boolean

On Error GoTo SystemErrorHandler
Dim oApp As Outlook.Application
Set oApp = New Outlook.Application
Dim oMail As Outlook.MailItem
Set oMail = oApp.CreateItem(olMailItem)

Dim i As Long

With oMail
    .To = "[email protected]"
    .CC = ""
    .BCC = ""
    .Subject = emSubject
    .HTMLBody = emBody
    For i = LBound(sfAttach) To UBound(sfAttach)
        .Attachments.Add sfAttach(i)
    Next i
    .Display
    '.Send
End With
Send_Email = True
Exit Function
SystemErrorHandler:
Send_Email = False

End Function

Example 2: Send Multiple Attachments through Multiple Emails

This is a more complex example. We need to first, identify the unique customers in our data range using Advanced Filter.

Then, we will loop over each customer and

• Find the email id for the customer.
• Find the invoices and gross amounts for the customer using Advanced Filter
• Populate an array with all the invoices that will need to be attached.
• Total the gross amounts and embed it into the body of the email.
• And, send these parameters to the Send Email function.

Full Code with Error Handling as Below.

Option Explicit

Const sFolderPath As String = "C:\Youtube\Outlook Tutorial 01\Outlook\Invoices\"
                  
' Define Subject
Const emSubject As String = "Overdue Invoices - Food Jar Co"

Sub Send_Multiple_Emails_Multi_Attach_w_Advanced_Filters()
Application.ScreenUpdating = False

' Clean up the worksheets
Call CleanUpWorksheets

' Create Invoice Header range
Dim rngCustomer As Range, rngInvHeader As Range
Dim lrowInvHeader As Long

lrowInvHeader = wsInvHeader.Range("A1").CurrentRegion.Rows.Count

Set rngInvHeader = wsInvHeader.Range("a1:f" & lrowInvHeader)
Set rngCustomer = wsInvHeader.Range("c1:c" & lrowInvHeader)

' First find unique customers

rngCustomer.AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=wsWork.Range("A1"), _
    Unique:=True

Dim sCustomerID As String, sInvoice As String
Dim lrowCustomer As Long, lrowFilteredRange As Long, lrowError As Long
Dim i As Long, j As Long
Dim emTotal As String
Dim emTo As String, emAttach As String, arrAttach() As String, emBody As String, sFileName As String

lrowCustomer = wsWork.Range("a1").CurrentRegion.Rows.Count

For i = 2 To lrowCustomer
    'Grab the Customer Name
    sCustomerID = wsWork.Range("A" & i).Value
    ' Assign it in range E as a criteria for the autofilter
    wsWork.Range("E2").Value = sCustomerID
    rngInvHeader.AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:=wsWork.Range("E1:E2"), _
        CopyToRange:=wsWork.Range("H1:I1"), _
        Unique:=False
    
    lrowFilteredRange = wsWork.Range("h1").CurrentRegion.Rows.Count
    emTo = GetEMailId(sCustomerID)
    emTotal = Application.WorksheetFunction.Sum(wsWork.Range("i2:i" & lrowFilteredRange))
    emTotal = Format(Application.WorksheetFunction.Sum(wsWork.Range("i2:i" & lrowFilteredRange)), "Currency")
    emBody = "Dear Customer,<br><br>" & _
            "We have attached invoices that are now overdue.<br>" & _
            "Total owing now is " & emTotal & ".<br>" & _
            "Prompt payment is expected.<br>" & _
            "Regards,<br><br>" & _
            "OSA Accounts"
    For j = 2 To lrowFilteredRange
        sInvoice = wsWork.Range("H" & j).Value
        sFileName = sFolderPath & sInvoice & ".pdf"
        emAttach = emAttach & sFileName & ","
    Next j
    emAttach = Left(emAttach, Len(emAttach) - 1)
    arrAttach = Split(emAttach, ",")
    If Not Send_Email_w_Multi_Attach(emTo, emBody, arrAttach) Then
        lrowError = wsError.Cells(wsError.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        wsError.Cells(lrowError, 1).Value = "Problem sending email for " & sCustomerID
    End If
    emAttach = ""
Next i

If wsError.Range("A2") <> "" Then
    MsgBox "Atleast one error found was detected."
    wsError.Activate
    Else
    MsgBox "All emails were sent successfully."
End If



Application.ScreenUpdating = True
End Sub


Sub CleanUpWorksheets()

wsError.Cells.Clear
wsWork.Cells.Clear

wsError.Range("A1").Value = "Status"
wsWork.Range("E1").Value = wsInvHeader.Range("C1").Value

wsWork.Range("h1").Value = wsInvHeader.Range("A1").Value
wsWork.Range("i1").Value = wsInvHeader.Range("f1").Value

End Sub

Function GetEMailId(fsCustomerID As String) As String

Dim targetCustomerID As String, targetEmailID As String
Dim lrowEmail As Long
Dim j As Long

lrowEmail = wsEmailId.Range("a1").CurrentRegion.Rows.Count

For j = 2 To lrowEmail
    targetCustomerID = wsEmailId.Range("A" & j).Value
    If fsCustomerID = targetCustomerID Then
        targetEmailID = wsEmailId.Range("B" & j).Value
        Exit For
    End If
Next j

GetEMailId = targetEmailID
End Function

Private Function Send_Email_w_Multi_Attach(sfTo As String, sfBody As String, sfAttach() As String) As Boolean

On Error GoTo SystemErrorHandler
Dim oApp As Outlook.Application
Set oApp = New Outlook.Application
Dim oMail As Outlook.MailItem
Set oMail = oApp.CreateItem(olMailItem)

Dim i As Long
With oMail
    .To = sfTo
    .CC = ""
    .BCC = ""
    .Subject = emSubject
    .HTMLBody = sfBody
    For i = LBound(sfAttach) To UBound(sfAttach)
        .Attachments.Add sfAttach(i)
        Next i
    .Display
        '.Send
End With
Send_Email_w_Multi_Attach = True
Exit Function
SystemErrorHandler:
    Send_Email_w_Multi_Attach = False


End Function