Attach multiple files or entire directory to email

Question

I'm trying to send an Outlook email with multiple attachments via Excel VBA.

The code works if I specify the path to one attachment/file. I can also add multiple attachments if I know exactly what they are, but I will not. There will be different counts as well as file names.

I would love to send using a wildcard as shown in my example below but I think I'll need to use some sort of loop pointing at a directory.

I looked but I am yet to see anything that works with my situation.

Private Sub Command22_Click()
    Dim mess_body As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = "test@test.org"
        .Subject = "test"
        .HTMLBody = "test"
        .Attachments.Add ("H:\test\Adj*.pdf")
        '.DeleteAfterSubmit = True
        .Send
    End With
    MsgBox "Reports have been sent", vbOKOnly
End Sub

Use [DIR](http://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba/10382861#10382861) — Siddharth Rout, Oct 03 '14 at 17:59
Thank you for your response. I tried .Attachments.Add Dir("H:\test\") and I received an error saying "Cannot find this file. Verify the path and file name are correct". — gfuller40, Oct 03 '14 at 18:08

score 13 · Accepted Answer · edited Jan 07 '22 at 08:26

Try this

Private Sub Command22_Click()
    Dim mess_body As String, StrFile As String, StrPath As String
    Dim appOutLook As Outlook.Application
    Dim MailOutLook As Outlook.MailItem
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set MailOutLook = appOutLook.CreateItem(olMailItem)

    '~~> Change path here
    StrPath = "H:\test\"
    
    With MailOutLook
        .BodyFormat = olFormatRichText
        .To = "test@test.org"
        .Subject = "test"
        .HTMLBody = "test"

        '~~> *.* for all files
        StrFile = Dir(StrPath & "*.*")
        
        Do While Len(StrFile) > 0
            .Attachments.Add StrPath & StrFile
            StrFile = Dir
        Loop
        
        '.DeleteAfterSubmit = True
        .Send
    End With
    
    MsgBox "Reports have been sent", vbOKOnly
End Sub

score 0 · Answer 2 · answered Nov 17 '21 at 15:07

I'm from Belgian and my English is not so very well. I changed the code from Siddharth Rout a little and it works. Thanks very very much Siddharth!! I was looking for this for a very long time

Private Sub Knop99_Click()

Dim mess_body As String, StrFile As String, StrPath As String Dim ÒutApp As Object Dim Outmail As Object

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.LogOn

Set Outmail = OutApp.CreateItem(0)

'~~> Wijzig hiet het pad
StrPath = "E:\Documenten\Conntracten\Test\Digitaal verstuurde contracten\"

With Outmail
     .To = '"test@test.org"
    .Subject = "test"
    .Body = "test"

    '~~> *.* Alle bestanden in de geselecteerde map worden als bijlage bij de email gevoegd
    StrFile = Dir(StrPath & "*.*")

    Do While Len(StrFile) > 0
        .Attachments.Add StrPath & StrFile
        StrFile = Dir
    Loop
    
    MsgBox "De conceptmail staat klaar", vbOKOnly

    .DeleteAfterSubmit = True
    
   ' MsgBox "De conceptmail staat klaar", vbOKOnly
    
    .Display
End With
 
Set Outmail = Nothing
Set OutApp = Nothing

End Sub

Please don't add "thank you" as an answer. Once you have sufficient [reputation](https://stackoverflow.com/help/whats-reputation), you will be able to [vote up questions and answers](https://stackoverflow.com/help/privileges/vote-up) that you found helpful. - [From Review](/review/late-answers/30366439) — no ai please, Nov 18 '21 at 06:56

Attach multiple files or entire directory to email

2 Answers2

Linked

Related