Sending emails to multiple recipients with multiple PDF files via VBA & Excel

The25th

New Member
Joined
Jun 19, 2019
Messages
6
I'm very new to VBA and found a code online that sends emails to multiple recipients but can only attach 1 file per email. I cannot find a code that works wherein it goes to a specific folder and attaches all PDF files that are stored in the folder and goes to a different folder and does the same for the next email recipient. The image shows the structure of the sheet that I am working on. I'm using Office 365.

Need help please, thank you.

Here's the Excel structure:


Here's my code:

<code style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-weight: inherit; font-stretch: inherit; line-height: inherit; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; vertical-align: baseline; box-sizing: inherit; white-space: inherit;">Sub SendMail()

ActiveWorkbook
.RefreshAll

Dim objOutlook AsObject
Dim objMail AsObject
Dim ws As Worksheet

Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

OnErrorGoTo MyHandler

ForEach cell In ws.Range("A2:A2000")

Set objMail = objOutlook.CreateItem(0)

With objMail
.To= cell.Value
.Cc ="email@email.com"
.Subject = cell.Offset(0,1).Value
.Body = cell.Offset(0,2).Value
.Attachments.Add cell.Offset(0,3).Value
.Display
EndWith

Set objMail =Nothing
Next cell

Set ws =Nothing
Set objOutlook =Nothing

MyHandler
:
MsgBox
"Review email messages"

EndSub</code>
 

Some videos you may like

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,758
Office Version
365, 2019, 2016
Platform
Windows
How about something like this? Change the path in the getAllFiles function for the folder that has the files you are looking to attach.

Code:
Sub SendMail()

ActiveWorkbook.RefreshAll

Dim SP() As String
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet

SP = Split(getAllFiles, ";")
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

On Error GoTo MyHandler

For Each cell In ws.Range("A2:A2000")

Set objMail = objOutlook.CreateItem(0)

With objMail
    .To = cell.Value
    .Cc = "email@email.com"
    .Subject = cell.Offset(0, 1).Value
    .Body = cell.Offset(0, 2).Value
    For i = LBound(SP) To UBound(SP)
        .Attachments.Add SP(i)
    Next i
    .Display
End With

Set objMail = Nothing
Next cell

Set ws = Nothing
Set objOutlook = Nothing

MyHandler:
MsgBox "Review email messages"

End Sub

Function getAllFiles() As String
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim sFil As Object
Dim sFol As Object
Dim res As String

Set sFol = FSO.getfolder("C:\Users\UserName\Documents\")

For Each sFil In sFol.Files
    res = res & sFol.Path & "\" & sFil.Name & ";"
Next sFil

getAllFiles = Left(res, Len(res) - 1)

End Function
 

The25th

New Member
Joined
Jun 19, 2019
Messages
6
Thanks, however this only captures all files from a specified folder in get files. I'm trying to get the files stored in each folder from C:\Temp"different_folders". Say folder 1 has 10 PDF files for email 1, then the 2nd folder has 5 PDF files for email 2, etc. Is there a way on getting that done? Also, I need to correct the image as I should specify "Folder Name" instead of filename.


 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,276
Replace your For Each cell .... Next cell code with this:
Code:
Dim fileName as String

For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))

    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To= cell.Value
        .Cc ="email@email.com"
        .Subject = cell.Offset(0,1).Value
        .Body = cell.Offset(0,2).Value
        fileName = Dir(cell.Offset(0,3).Value & "\*.pdf")
        While fileName <> vbNullString
            .Attachments.Add cell.Offset(0,3).Value & "\" & fileName
            fileName = Dir()
        Wend
        .Display
    EndWith

    Set objMail = Nothing
Next cell
 

The25th

New Member
Joined
Jun 19, 2019
Messages
6
The code did not capture the files in the separate folders, it just created the email without the attachment. What did I do wrong, please help? Here's the code:
Sub SendMail()

ActiveWorkbook.RefreshAll

Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Dim fileName As String


Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet

On Error GoTo MyHandler


For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))


Set objMail = objOutlook.CreateItem(0)


With objMail
.To = cell.Value
.Cc = "email@email.com"
.Subject = cell.Offset(0, 1).Value
.Body = cell.Offset(0, 2).Value
fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
While fileName <> vbNullString
.Attachments.Add cell.Offset(0, 3).Value & "" & fileName
fileName = Dir()
Wend
.Display
End With


Set objMail = Nothing
Next cell


Set ws = Nothing
Set objOutlook = Nothing


MyHandler:
MsgBox "Review email message"


End Sub
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,276
You didn't apply or post my code correctly (use CODE tags - the # icon in the message editor). It should be:

Code:
fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
            While fileName <> vbNullString
                .Attachments.Add cell.Offset(0, 3).Value & "\" & fileName
                fileName = Dir()
            Wend
Column D is expected to be the full folder path of the folder containing .pdf files to be attached, for example D2 "C:\TEMP\202761" contains .pdf files. There should be no trailing back slash on the path.

Also, delete the On Error GoTo line, or put a comment character (apostrophe) at the start of the line, and run the macro and see if an error occurs.
 

The25th

New Member
Joined
Jun 19, 2019
Messages
6
Thank you so much! It now work, a small hiccup though. The email keeps on creating even though the list ends. How do I stop the code when the list ends?
 

The25th

New Member
Joined
Jun 19, 2019
Messages
6
Thank you so much! It now work, a small hiccup though. The email keeps on creating even though the list ends. How do I stop the code when the list ends?
Here's the full working code (I removed the CC part):

Code:
Sub SendMail()

    ActiveWorkbook.RefreshAll
    
    Dim objOutlook As Object
    Dim objMail As Object
    Dim ws As Worksheet
    Dim fileName As String


    Set objOutlook = CreateObject("Outlook.Application")
    Set ws = ActiveSheet
    
  For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))


    Set objMail = objOutlook.CreateItem(0)


        With objMail
            .To = cell.Value
            .Subject = cell.Offset(0, 1).Value
            .Body = cell.Offset(0, 2).Value
            fileName = Dir(cell.Offset(0, 3).Value & "\*.pdf")
                        While fileName <> vbNullString
                            .Attachments.Add cell.Offset(0, 3).Value & "\" & fileName
                            fileName = Dir()
                        Wend
            .Display
        End With


        Set objMail = Nothing
    Next cell


    Set ws = Nothing
    Set objOutlook = Nothing




End Sub
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,276
Your code looks correct, though add this line in the Dims:
Code:
    Dim cell As Range
The line

Code:
For Each cell In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
loops from A2 to the last populated cell in column A (i.e. the end of the list of emails), so the macro should end when the list ends.

Make sure the sheet you showed in your OP is the active sheet when you run the macro, because the code assigns ActiveSheet to the ws object.
 

Watch MrExcel Video

Forum statistics

Threads
1,099,856
Messages
5,471,143
Members
406,746
Latest member
jaredc

This Week's Hot Topics

Top