Excel VBA to Send Multiple Attachments via Outlook

[Trevor G]

Hi I am trying to send multiple attachments form Excel VBA to Outlook, I can send single attachments but when I add (what I thought would work) the code for multiple attachments it only attaches the last item and not the first. The code I am using is as follows:

[face=Courier New][COLOR=darkblue]Sub[/COLOR] EmailListNew()

[COLOR=green]'Column G holds the email addresses[/COLOR]
[COLOR=green]'Column A holds the salutation[/COLOR]
[COLOR=green]'Column K holds Yes or No to send[/COLOR]
[COLOR=green]'Adjusted code by Trevor G October 2012[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] OutApp [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] OutMail [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] myFileList [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] i [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]Set[/COLOR] OutApp = CreateObject("Outlook.Application")

    myFileList(0) = "C:\Users\Trevor G\ Article 2012.doc"
    myFileList(1) = "C:\Users\Trevor G\broucher2012.pdf"
    
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] cleanup
    Sheets("Availability").Activate
        [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] Columns("G").Cells.SpecialCells(xlCellTypeConstants)
        [COLOR=darkblue]If[/COLOR] cell.Value [COLOR=darkblue]Like[/COLOR] "?*@?*.?*" And _
           LCase(Cells(cell.Row, "K").Value) = "yes" [COLOR=darkblue]Then[/COLOR]

            [COLOR=darkblue]Set[/COLOR] OutMail = OutApp.CreateItem(0)
            [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
            [COLOR=darkblue]With[/COLOR] OutMail
                .To = cell.Value
                .Subject = Cells(cell.Row, "H").Value
                .Body = "Dear " & Cells(cell.Row, "A").Value _
                      & vbNewLine & vbNewLine & _
                      Cells(cell.Row, "I").Value _
                      & vbNewLine & vbNewLine & _
                      Cells(cell.Row, "J").Value
                      
                [COLOR=green]'This is the code which is to send multiple attachments and fails[/COLOR]
                [COLOR=green]'It is only sending the last Item in the list[/COLOR]
                [COLOR=darkblue]For[/COLOR] i = [COLOR=darkblue]LBound[/COLOR](myFileList) [COLOR=darkblue]To[/COLOR] [COLOR=darkblue]UBound[/COLOR](myFileList)
                .Attachments.Add myFileList(i)
                [COLOR=darkblue]Next[/COLOR] i
                
                [COLOR=green]'.Send  'Or use .Display[/COLOR]
                .Display
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
            [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
            [COLOR=darkblue]Set[/COLOR] OutMail = [COLOR=darkblue]Nothing[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Next[/COLOR] cell

cleanup:
    [COLOR=darkblue]Set[/COLOR] OutApp = [COLOR=darkblue]Nothing[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR][/face]

 

[wigi]

Hi there

For me it works when I use this declaration:

Dim myFileList(1) As String

 

[wigi]

Also, consider:

Sub EmailListNew()

'Column G holds the email addresses
'Column A holds the salutation
'Column K holds Yes or No to send
'Adjusted code by Trevor G and Wim Gielis, October 2012

    Dim cell As Range
    Dim myFileList(1) As String
    Dim i As Long
    
    Application.ScreenUpdating = False

     myFileList(0) = "C:\Users\Trevor G\ Article 2012.doc"
     myFileList(1) = "C:\Users\Trevor G\broucher2012.pdf"

    On Error GoTo EndOfSub
    Sheets("Availability").Activate
    For Each cell In Columns("G").Cells.SpecialCells(2, 2)
        If cell.Text Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "K").Text) = "yes" Then

            On Error Resume Next
            With CreateObject("Outlook.Application").CreateItem(0)
                .To = cell.Text
                .Subject = Cells(cell.Row, "H").Value
                .Body = Replace("Dear " & Cells(cell.Row, "A").Value & "#" & Cells(cell.Row, "I").Value & "#" & Cells(cell.Row, "J").Value, "#", vbNewLine & vbNewLine)
                For i = 0 To UBound(myFileList)
                    .Attachments.Add myFileList(i)
                Next
                .Send  'Or use .Display
            End With
            On Error GoTo 0
        End If
    Next

EndOfSub:

End Sub

 

[Trevor G]

Thank you Wigi, works lovely and I will keep your comments in as well, also thanks for the updated option.

 

[anbub1]

Hi Mr. Wigi,

I have different problem. Col A has filenames and these files are stored in D:\test\. Col C, D, and E has email address for To, CC and BCC respectively. Range ("F2") will act as mail subject and Range(("F3") will be message. Subject and message will be constant for all mails. While running macro, file name in col A need to be attached from D:\test\ and sent to the addresses in col C,D,and E with subject and message.

(I tried to attach my excel file, but don't know how to add here)

 

[jackcluseau]

Hi sir,

I am new to excel VBA,I do see that ur code helps in attaching multiple files, can you please help me with a code in the same context however with a little twist like as follows:

Col A has salutation
Col B has email address
Col C has yes or no , if yes then send mail to email address in col B same row
Col D has path of jpeg files
Col E has "Used" text if the path of jpeg file is used already to send the attachment to an email address

The macro should attach one file only out of available paths in col D and once attached put text Used in col E and then move on to the next recipients with text Yes in col C.

I hope you can help me with a VBA code.

Regards,
Jack

Also, consider:

Sub EmailListNew()

'Column G holds the email addresses
'Column A holds the salutation
'Column K holds Yes or No to send
'Adjusted code by Trevor G and Wim Gielis, October 2012

    Dim cell As Range
    Dim myFileList(1) As String
    Dim i As Long
    
    Application.ScreenUpdating = False

     myFileList(0) = "C:\Users\Trevor G\ Article 2012.doc"
     myFileList(1) = "C:\Users\Trevor G\broucher2012.pdf"

    On Error GoTo EndOfSub
    Sheets("Availability").Activate
    For Each cell In Columns("G").Cells.SpecialCells(2, 2)
        If cell.Text Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "K").Text) = "yes" Then

            On Error Resume Next
            With CreateObject("Outlook.Application").CreateItem(0)
                .To = cell.Text
                .Subject = Cells(cell.Row, "H").Value
                .Body = Replace("Dear " & Cells(cell.Row, "A").Value & "#" & Cells(cell.Row, "I").Value & "#" & Cells(cell.Row, "J").Value, "#", vbNewLine & vbNewLine)
                For i = 0 To UBound(myFileList)
                    .Attachments.Add myFileList(i)
                Next
                .Send  'Or use .Display
            End With
            On Error GoTo 0
        End If
    Next

EndOfSub:

End Sub