VBA attach multiple files to email from folder

[ChloeSpurge]

Hi All,

I have this code that creates emails for each row in my table (a different customer) then adds a file, subject etc. However, it only works when the customer has one file, and some emails need up to 10 or more files attaching. I've put the file names in column B separated by commas, anyway to get the code to run through and add all the files?

Thanks for any help
Chloe

 

[Sequoyah]

Hi Chloe, here's my suggestion

Sub Test_emails()
'https://www.mrexcel.com/board/threads/vba-attach-multiple-files-to-email-from-folder.1214138/

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim path As String, LBody As String, MyFile As String

Dim Attachments() As String
Dim i As Integer

path = "C:\Users\chloe\Contractor\IA\P318 File V2\P318 File\"

Dim RList As Range
Set RList = Range("A2", Range("A2").End(xlDown))
Dim R As Range
For Each R In RList
Set EItem = EApp.CreateItem(0)

With EItem
.To = R.Offset(0, 2)
.Subject = "3183 Week " & R.Offset(0, 4) & " - " & R.Offset(0, 3)
MyFile = R.Offset(0, 1)

If MyFile <> "" Then
    Attachments = Split(MyFile, ",")
    For i = LBound(Attachments) To UBound(Attachments)
        If Attachments(i) <> "" Then
            .Attachments.Add path & Trim(Attachments(i))
        End If
    Next i
End If

LBody = "Hi," & vbNewLine & vbNewLine _
& "Please find the 3183 for your allocated duties for week " & R.Offset(0, 4) & " attached." _
& vbNewLine & vbNewLine & "Many thanks"
.Display
End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub

 

[ChloeSpurge]

Great thank you it works! Only one thing, when there's just one customer in the table, it creates a lot of empty emails, I'm guessing its something to do with the Range("A2", Range("A2").End(xlDown)), is there a way to stop this?

 

[Sequoyah]

Hi Chloe,
thank you for the feedback, edit the line of code as follows

Set RList = Range("A2", Range("A1").End(xlDown))

PS I believe you will have a better chance of getting help by posting the code instead of an image

 

[ChloeSpurge]

Hi Chloe,
thank you for the feedback, edit the line of code as follows

Set RList = Range("A2", Range("A1").End(xlDown))

PS I believe you will have a better chance of getting help by posting the code instead of an image

Great thanks again it works perfectly!

good plan, will do in future

Chloe

 

[ChloeSpurge]

Hi Chloe,
thank you for the feedback, edit the line of code as follows

Set RList = Range("A2", Range("A1").End(xlDown))

PS I believe you will have a better chance of getting help by posting the code instead of an image

Hi, its me again. Is there a way to get the VBA to produce a pop up if a file that needs to be attached cannot be found in the folder? Then continuous as normal after? At the moment the whole macro stops Thanks Again

 

[ChloeSpurge]

Great thanks again it works perfectly!

good plan, will do in future

Chloe

Hi, the body of the email doesn't seem to be added anymore? any reasons why?

Thanks
Chloe

 

[Sequoyah]

Hi Chloe,
it's my fault - .Body inadvertently became LBody.
I added the code to verify the existence of the file to attach, otherwise an error message appears and the macro stops.

Sub Test_emails2()
'https://www.mrexcel.com/board/threads/vba-attach-multiple-files-to-email-from-folder.1214138/

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim path As String, LBody As String, MyFile As String

Dim Attachments() As String, ExistFile() As String
Dim i As Integer, j As Integer

path = "C:\Users\chloe\Contractor\IA\P318 File V2\P318 File\"

Dim RList As Range
Set RList = Range("A2", Range("A1").End(xlDown))
Dim R As Range

For Each R In RList
MyFile = R.Offset(0, 1)
    ExistFile = Split(MyFile, ",")
    For j = LBound(ExistFile) To UBound(ExistFile)
        If Dir(path & ExistFile(j)) = "" Then
            MsgBox (path & (ExistFile(j)) & " doesn't exist")
        
        Exit Sub
        End If
    Next j

Next R

For Each R In RList
Set EItem = EApp.CreateItem(0)

With EItem
.To = R.Offset(0, 2)
.Subject = "3183 Week " & R.Offset(0, 4) & " - " & R.Offset(0, 3)
MyFile = R.Offset(0, 1)

If MyFile <> "" Then
    Attachments = Split(MyFile, ",")
    For i = LBound(Attachments) To UBound(Attachments)
        If Attachments(i) <> "" Then
            .Attachments.Add path & Trim(Attachments(i))
        End If
    Next i
End If

.Body = "Hi," & vbNewLine & vbNewLine _
& "Please find the 3183 for your allocated duties for week " & R.Offset(0, 4) & " attached." _
& vbNewLine & vbNewLine & "Many thanks"
.Display
End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub

 

[ChloeSpurge]

Hi Chloe,
it's my fault - .Body inadvertently became LBody.
I added the code to verify the existence of the file to attach, otherwise an error message appears and the macro stops.

Sub Test_emails2()
'https://www.mrexcel.com/board/threads/vba-attach-multiple-files-to-email-from-folder.1214138/

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")
Dim EItem As Object
Dim path As String, LBody As String, MyFile As String

Dim Attachments() As String, ExistFile() As String
Dim i As Integer, j As Integer

path = "C:\Users\chloe\Contractor\IA\P318 File V2\P318 File\"

Dim RList As Range
Set RList = Range("A2", Range("A1").End(xlDown))
Dim R As Range

For Each R In RList
MyFile = R.Offset(0, 1)
    ExistFile = Split(MyFile, ",")
    For j = LBound(ExistFile) To UBound(ExistFile)
        If Dir(path & ExistFile(j)) = "" Then
            MsgBox (path & (ExistFile(j)) & " doesn't exist")
       
        Exit Sub
        End If
    Next j

Next R

For Each R In RList
Set EItem = EApp.CreateItem(0)

With EItem
.To = R.Offset(0, 2)
.Subject = "3183 Week " & R.Offset(0, 4) & " - " & R.Offset(0, 3)
MyFile = R.Offset(0, 1)

If MyFile <> "" Then
    Attachments = Split(MyFile, ",")
    For i = LBound(Attachments) To UBound(Attachments)
        If Attachments(i) <> "" Then
            .Attachments.Add path & Trim(Attachments(i))
        End If
    Next i
End If

.Body = "Hi," & vbNewLine & vbNewLine _
& "Please find the 3183 for your allocated duties for week " & R.Offset(0, 4) & " attached." _
& vbNewLine & vbNewLine & "Many thanks"
.Display
End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub

Great thank you