Add multiple attachments from While statement to email argument

Question

I'm working with legacy code and trying to update their email code from a bunch of multiple email code to a single call. I've been successful until I ran into a While Wend statement for attachments.

I'm using the following Public Sub to call these emailers.

Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, Optional ByVal carboncopy As String, Optional attachment0 As String, Optional attachment1 As String, Optional attachement2 As String, Optional attachement3 As String, Optional attachement4 As String)
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Shell "outlook.exe", vbNormalFocus
    Else
        AppActivate objOutlook.ActiveExplorer.Caption
    End If
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
    With OutApp
        .Session.Logon
        Set OutMail = .CreateItem(olMailItem)
    End With
    With OutMail
        .To = recipient
        If carboncopy <> "" Then
            .CC = carboncopy
        End If
        .subject = subject
        .Body = bodyText
        If attachment0 <> "" Then
            .Attachments.Add attachment0
        End If
        If attachment1 <> "" Then
            .Attachments.Add attachment1
        End If
        If attachment2 <> "" Then
            .Attachments.Add attachment2
        End If
        If attachment3 <> "" Then
            .Attachments.Add attachment3
        End If
        If attachment4 <> "" Then
            .Attachments.Add attachment4
        End If
        If SendDisplay Then
            .Display True
        Else
            .Send
        End If
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

The snippet I am having an issue with is code that attaches all files in a folder with a While Wend loop.

    With OutMail
        While Len(strFileName) > 0
              .Attachments.Add (strDir & strFileName)
              strFileName = Dir
        Wend
        .subject = (MySub)
        .Body = strbody
        .BodyFormat = olFormatPlain '1
        .Display True
    End With

I'm trying to convert the above With to

SendEmail "", (MySub), strbody, True, , ???

My question is what is the best way to get these attachments from this While Wend loop?

The code is located in a userform and all the files are created when the form loads and exports selected worksheets from a ComboBox and a button to Export is pressed as a PDF to a folder.

Is there a way to use While to add the files to the argument for attaching in the SendEmail sub? Is there a way to add these files to the argument from the folder?

Thank you for your time.

EDIT FOR CLEARER EXPLANATION

When the Userform is initialized it will load all visible worksheets in to ComboBox1. An item is selected from ComboBox1 and CommandButton1 is pressed to export just the selected sheet.

Private Sub CommandButton1_Click()
    If (ComboBox1.Text = "") Then
        MsgBox ("Select a sheet to Export to PDF.")
        Exit Sub
    End If
    Set rngRange = Worksheets("DM").Range("D10")
    If ComboBox1.Value = "TR" Then
        setname = "Treatment Report"
    ElseIf ComboBox1.Value = "DM" Then
        setname = "Data Master Cover"
    ElseIf ComboBox1.Value = "JHA" Then
        setname = "JHA"
    ElseIf ComboBox1.Value = "SIGN" Then
        setname = "Safety Meeting Sign In Sheet"
    Else
        setname = Worksheets("DM").Range("B41")
    End If
    bolSelected = True
    strDirname = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value
    strFileName = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value & " " & setname
    strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
    If Dir(strDir, vbDirectory) = vbNullString Then MkDir strDir
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=strDir & "\" & strFileName, openafterpublish:=False, ignoreprintareas:=False
    MsgBox "File exported to My Documents.", , "EXPORT COMPLETE"
    Worksheets("DM").Select
End Sub

When all the sheets that the user requires is exported (it could be one or two or three or all of them), the user presses CommandButton2, which asks to email the sheets they exported, if yes it will run through this email form.

Private Sub CommandButton2_Click()
    If bolSelected = True Then
        If MsgBox("Do you want to email exported files now?", vbYesNo, "EMAIL ITEMS") = vbYes Then
            On Error Resume Next
            Set objOutlook = GetObject(, "Outlook.Application")
            If Err.Number = 429 Then
                Shell "outlook.exe", vbNormalFocus
            Else
                AppActivate objOutlook.ActiveExplorer.Caption
            End If
            Set OutApp = GetObject(, "Outlook.Application")
            If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
            With OutApp
                .Session.Logon
                Set OutMail = .CreateItem(olMailItem) '0
            End With
            strDirname = strDirname & "\"
            strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
            strFileName = Dir(strDir)
            strbody = "This file was sent by " & vbNewLine & vbNewLine & _
            Application.UserName & vbNewLine & _
            "on " & Format(Date, "MMMM/dd/yyyy")
            With OutMail
                While Len(strFileName) > 0
                      .Attachments.Add (strDir & strFileName)
                      strFileName = Dir
                Wend
                .Subject = (MySub)
                .Body = strbody
                .BodyFormat = olFormatPlain '1
                .Display True
            End With
            Set OutMail = Nothing
            Set OutApp = Nothing
            Unload Me
        Else
            Unload Me
        End If
    Else
        Unload Me
    End If
End Sub

I created a new Module called "Post_Office" that all email code uses, "SendEmail", this workbook has 6 of the above code scattered about. SendEmail works on 5 out of the 6 as if there are attachments, they will always exist.

This is the only Userform where the files attached to an email may or may not exist.

Is there a way to get the files created from this Userform to attach to the email like the While Wend statement from above?

Answer 1

This can be achieved by ParamArray VBA, ParamArray attachments(), like this:

Option Explicit

Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, ByVal carboncopy As String, _
  ParamArray attachments())

    Dim x
    Dim OutMail As Object, objOutlook As Object
    
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Shell "outlook.exe", vbNormalFocus
        Set objOutlook = GetObject(, "Outlook.Application")
    Else
        AppActivate objOutlook.ActiveExplorer.Caption
    End If
    If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application")
    
    With objOutlook
        .Session.Logon
        Set OutMail = .CreateItem(olMailItem)
    End With
    With OutMail
        .To = recipient
        If carboncopy <> "" Then
            .CC = carboncopy
        End If
        .subject = subject
        .Body = bodyText
        
        For Each x In attachments
          If x <> "" Then
            .attachments.Add x
          End If
        Next
        
        If SendDisplay Then
            .Display True
        Else
            .Send
        End If
    End With
    Set OutMail = Nothing
    Set objOutlook = Nothing
End Sub

'
' SendEmail "", (MySub), strbody, True, , ???
'
Sub doSendmail()
  SendEmail "johndoe@example.com", "Test", "Hello body", True, "", "filename", "filename2", "filename3", "filename4"
End Sub

We replace with this loop to add attachments():

        For Each x In attachments
          If x <> "" Then
            .attachments.Add x
          End If
        Next