Trying to add multiple files to an email message

I am using the following code in an attempt to attach multiple files to an email.  In some cases there may be just one file to attach but in other cases more than one.  The code as it exists right now only sends the first file even if there are two files to be send.  It needs to send both files in the email if there are more than one.

    strAttachment = Me.txtCastingPrintsDataPath   'strAttachment is the path to the attachments
    
    For j = 1 To 5
    filename = Dir(strAttachment)
        If Me("chkbxPatternSource" & j) = True Then
            Set objMail = olApp.CreateItem(olMailItem)
            strEmail = Me("txtPatternSourceEmail" & j) & ";"
            With objMail
                .To = strEmail
                .Subject = strSubject
                .HTMLBody = strHTMLBody
                .Attachments.Add strAttachment & filename
                .Send
            End With
        End If
    Next

    Set objMail = Nothing
    Set olApp = Nothing
    
    End If

Open in new window

SteveL13Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Scott McDaniel (Microsoft Access MVP - EE MVE )Infotrakker SoftwareCommented:
Try this:

Do While Len(filename) > 0
  .Attachments.Add strAttachment & filename
  '/ get the next file in the directory
  filename = Dir
Loop

The code block above would replace the single "Attachments" line in your code. Calling Dir again in the loop tells VBA to get the "next" file. This will get ALL files in the directory, so be careful what you place there.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
SteveL13Author Commented:
Nice!  Thanks.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.