Send same email to multiple recipients with different attachment

Question

I think there might be a way to do this with VBA, but I can't find any documentation on how to add attachments via VBA.

Here's some example code I've found:

Sub SendMultipleEmails()
Dim objMail As Outlook.MailItem
Dim intX As Integer


For intX = 1 To 10 'Or get the value of intX from a file count
Set objMail = Application.CreateItem(olMailItem)
objMail.Subject = "My subject line"
objMail.Body = "My message body"
objMail.To = "
objMail.Attachments.Add "C:\temp\myfile.doc"
objMail.Send
Set objMail = Nothing
Next
End Sub

My only challenge now is to create a loop that allows me to send a different attachment to each recipient. The recipients will be alphabetically ordered, and the files are too, so it's just a matter of using the index number of the file in a loop.

Solution 1

This, very simply, allows the user to send emails to multiple recipients with different attachments for each. In my spreadsheet I put the emails and file paths in cells, and the For loop picks out each individual recipient and file each time it runs through.

Sub SendMultipleEmails()

Dim Mail_Object, OutApp As Variant


 With ActiveSheet
    lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With

For i = 2 To lastrow

Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)

    With OutApp
    .Subject = "Your subject here"
    .Body = "Your message here"
    .To = Cells(i, 2).Value
    .Attachments.Add Cells(i, 4).Value
    .send
    End With

Next i

debugs:
If Err.Description <> "" Then MsgBox Err.Description

End Sub

Solution 2

Thanks for providing this useful code snippet. I have extended it to allow for multiple attachments and would like to share it with you:

Sub SendMultipleEmails()

    Dim Mail_Object, OutApp As Object
    Dim lastRow, i, j As Integer

     With ActiveSheet
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        End With

    For i = 2 To lastRow
        Set Mail_Object = CreateObject("Outlook.Application")
        Set OutApp = Mail_Object.CreateItem(0)
        OutApp.display
        Call AddAttachments(OutApp, Cells(i, 4).Value)
        With OutApp
        .Subject = Cells(8, "N").Value
        .Body = Cells(10, "N").Value
        .To = Cells(i, 2).Value
        .send
        End With

    Next i

    debugs:
    If Err.Description <> "" Then MsgBox Err.Description

End Sub

Sub AddAttachments(ByRef OutApp As Object, ByVal FilePathToAdd As String)
    Dim Attachments() As String
    Dim j As Integer

    If FilePathToAdd <> "" Then
        Attachments = Split(FilePathToAdd, ";")
        For j = LBound(Attachments) To UBound(Attachments)
            If Attachments(j) <> "" Then
                OutApp.Attachments.Add Trim(Attachments(j))
            End If
        Next j
    End If
End Sub

Comments

[Admin]

Check out stackoverflow.com/questions/9038926/… which shows how to do this via Windows Scripting and with Blat (which I highly recommend)

[Admin]

I'll be doing this without Blat, VBA does what I need it to do

[Admin]

Well, give writing it a try and let us know if it doesn't work.