Macro to Allow User to Select Multiple PDF Files

[howard]

I have written code to allow a user to attach multilple PDF Files


I selected two diifferent Files in "C:\My documents"", but the same file was attached twice


It would be appreciated if someone could kindly amend theportion of my code to enable a user to attach multiple files

The rest of the code works 100%


It appears that it is only this portion of my code that needs to be amended to accomodate my request

 Dim fd As Office.FileDialog: Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim strFile As String

With fd
    .Filters.Clear
    .Filters.Add "PDF files", "*.pdf", 1
    .Title = "Choose the PDF file to attach"
    .AllowMultiSelect = True
.InitialFileName = "C:\my documents" 'Verify this is the correct path; will error if not
    If .Show = True Then
        strFile = .SelectedItems(2)
    End If
End With

See full code below

 Sub Email_andattachfiles()
 
Dim File As String, strBody As String, LR As Long

Dim TheFile As String: TheFile = Sheets("data").Range("A42")

With Application
          .ScreenUpdating = False
          .DisplayAlerts = False
End With

File = Environ$("temp") & "\" & Sheets("Data").Range("A42") & ".xlsx"
strBody = "Hi " & Sheets("Data").Range("AT1") & vbNewLine & vbNewLine & _
        "Attached, please find Journal Entries to be printed" & vbNewLine & vbNewLine & _
            "Regards" & vbNewLine & vbNewLine & _
            "Howard"

    Set rng = Nothing
  
   
   Sheets("Data").Range("Journals").Copy
   
Workbooks.Add
ActiveSheet.Range("a1").PasteSpecial xlPasteValues
ActiveSheet.Range("a1").PasteSpecial xlPasteFormats
ActiveSheet.Range("a1").PasteSpecial xlPasteColumnWidths

Sheets(1).Name = "Data"
  LR = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
With ActiveWorkbook
With ActiveSheet.PageSetup
.PrintGridlines = True
.PrintArea = "A2:E" & LR + 10
.PrintTitleRows = "$1:$1"
.PrintTitleColumns = ""
.LeftHeader = "&D&T"
.CenterHeader = "Branch Interest Calcs"
.Orientation = xlLandscape
.FitToPagesWide = 1
End With

Sheets(1).Select
    ActiveWindow.View = xlPageBreakPreview

   .SaveAs Filename:=File, FileFormat:=51
   .Close SaveChanges:=False
End With

Dim fd As Office.FileDialog: Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim strFile As String

With fd
    .Filters.Clear
    .Filters.Add "PDF files", "*.pdf", 1
    .Title = "Choose the PDF file to attach"
    .AllowMultiSelect = True
.InitialFileName = "C:\my documents" 'Verify this is the correct path; will error if not
    If .Show = True Then
        strFile = .SelectedItems(2)
    End If
End With

DoEvents

With CreateObject("Outlook.Application").CreateItem(0)
     ActiveWindow.View = xlPageBreakPreview
       
     .To = Join(Application.Transpose(Sheets("Data").Range("AU1:AU2").Value), ";")
       
     .Subject = Sheets("Data").Range("a42")
     .body = strBody
 '    .attachments.Add File 'Adds the .xlsx file declared above
     .attachments.Add strFile 'Adds the PDF selected with the FilePicker
          .attachments.Add strFile 'Adds the PDF selected with the FilePicker
     DoEvents
     .Display
End With
Kill File
ActiveWindow.View = xlNormalView
With Application
          .ScreenUpdating = True
          .DisplayAlerts = True
End With
End Sub

Your assistance in rresolving this is most appreciated

 

[Domenic]

For your file picker...

    With fd
        .Filters.Clear
        .Filters.Add "PDF files", "*.pdf", 1
        .Title = "Choose the PDF file to attach"
        .AllowMultiSelect = True
        .InitialFileName = "C:\my documents" 'Verify this is the correct path; will error if not
        If .Show = 0 Then Exit Sub
        ReDim arrResults(1 To .SelectedItems.Count)
        Dim i As Long
        For i = 1 To .SelectedItems.Count
            arrResults(i) = .SelectedItems(i)
        Next i
    End With

To attach the PDF files to your email...

    For i = LBound(arrResults) To UBound(arrResults)
        .attachments.Add arrResults(i)
    Next i

Hope this helps!

 

[howard]

Hi Domenic


Many thanks for your help. Your code works 100%

 

[Domenic]

That's great to hear, I'm glad I could help.

Cheers!