VBA to Browse for Folder and Merge Files - PDF

damaniam1604

New Member
Joined
Sep 12, 2018
Messages
20


The call of this macro seems easier to explain than tolocate online. I'm rather green in VBA, so any related items I have foundlooked like Greek to me. Any assistance is greatly appreciated.

The call of the Macro:


  • Open Shell App to allow me to browse for afolder on my computer

  • Select desired folder via shell app

  • Combine all .pdf files in the desired folderinto a single .pdf

  • Save newly created .pdf in the desired folder

  • Name of the newly created .pdf is in A1

    P.S.: I am currently using Office 365 for excel and Adobe AcrobatPro DC


 
Hi, my bad - two misprints were fixed now, the code below passed testing succesfully:
Rich (BB code):
Sub Main()
 
  Dim DestFile As String  ' <-- ZVI:2018-11-08
 
  Dim MyPath As String, MyFiles As String
  Dim a() As String, i As Long, f As String, Arr
 
  ' Choose the folder or just replace that part by: MyPath = Range("E3")
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "D:\Dropbox\User\All Entities\Financials\"
    .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    MyPath = .SelectedItems(1)
    DoEvents
  End With
 
  ' Populate the array a() by PDF file names
  If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
 
  '--> ZVI:2018-11-08 Build DestFile using 2 last (sub)folders
  Arr = Split(MyPath, "\")
  If UBound(Arr) > 2 Then DestFile = Arr(UBound(Arr) - 1) & " - "
  If UBound(Arr) > 3 Then DestFile = Arr(UBound(Arr) - 2) & " - " & DestFile
  DestFile = DestFile & "Financial Statement.pdf"
  '<--
 
  ReDim a(1 To 2 ^ 14)
  f = Dir(MyPath & "*.pdf")
  While Len(f)
    If StrComp(f, DestFile, vbTextCompare) Then
      i = i + 1
      If Not LCase(f) Like "*.pdf" Then f = f & ".pdf" ' <-- ZVI:2018-11-08
      a(i) = f
    End If
    f = Dir()
  Wend
 
  ' Merge PDFs
  If i Then
    ReDim Preserve a(1 To i)
    MyFiles = Join(a, ",")
    Application.StatusBar = "Merging, please wait ..."
    Call MergePDFs(MyPath, MyFiles, DestFile)
    Application.StatusBar = False
  Else
    MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
  End If
 
End Sub
 
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
  ' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
  ' Reference required: VBE - Tools - References - Acrobat XX.0 Type Library
 
  Dim a As Variant, i As Long, n As Long, ni As Long, p As String
  Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.AcroPDDoc
 
  If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
  a = Split(MyFiles, ",")
  ReDim PartDocs(0 To UBound(a))
 
  On Error GoTo exit_
  If Len(Dir(p & DestFile)) Then Kill p & DestFile
  For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & a(i)) = "" Then        ' <-- ZVI:2018-11-08 Without Trim()
      MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
      Exit For
    End If
    ' Open PDF document
    Set PartDocs(i) = New Acrobat.AcroPDDoc
    PartDocs(i).Open p & a(i)         '<--ZVI:2018-11-08 without Trim()
    If i Then
      ' Merge PDF to PartDocs(0) document
      ni = PartDocs(i).GetNumPages()
      If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
        MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
      End If
      ' Calc the number of pages in the merged document
      n = n + ni
      ' Release the memory
      PartDocs(i).Close
      Set PartDocs(i) = Nothing
    Else
      ' Calc the number of pages in PartDocs(0) document
      n = PartDocs(0).GetNumPages()
    End If
  Next
 
  If i > UBound(a) Then
    ' Save the merged document to DestFile
    If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
      MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
    End If
  End If
 
exit_:
 
  ' Inform about error/success
  If Err Then
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number
    ElseIf i > UBound(a) Then
    MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
  End If
 
  ' Release the memory
  If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
  Set PartDocs(0) = Nothing
 
  ' Quit Acrobat application
  AcroApp.Exit
  Set AcroApp = Nothing
 
End Sub
 
Last edited:
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
ZVI,
I can’tthank you enough for all of your help. I still run in to the same error frombefore. I found the below bit of code at the link below. Using the Acrobat.tlbreference this macro works perfectly.
Based onthis, it would seem that the error comes from either browsing to the foldercontaining the multiple pdf files or with creating the array of names and pagenumbers. Obviously, the code below won’t work for my needs since it doesn’thave the browse to folder functionality and nor do my files have known names.

If you couldlook over this and give me some advice, I would appreciate it.
http://khkonsulting.com/2009/03/adobe-acrobat-and-vba-an-introduction/

Code:
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim AcroApp As Acrobat.CAcroApp[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim Part1Document As Acrobat.CAcroPDDoc[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim Part2Document As Acrobat.CAcroPDDoc[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim numPages As Integer[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set AcroApp =CreateObject("AcroExch.App")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set Part1Document =CreateObject("AcroExch.PDDoc")[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set Part2Document =CreateObject("AcroExch.PDDoc")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Part1Document.Open("C:\temp\Part1.pdf")[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Part2Document.Open("C:\temp\Part2.pdf")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    ' Insert the pages of Part2 after the endof Part1[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    numPages = Part1Document.GetNumPages()[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    If Part1Document.InsertPages(numPages - 1,Part2Document,[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]                                0,Part2Document.GetNumPages(), True) = False Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        MsgBox "Cannot insert pages"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    End If[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    If Part1Document.Save(PDSaveFull,"C:\temp\MergedFile.pdf") = False Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        MsgBox "Cannot save the modifieddocument"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    End If[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Part1Document.Close[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Part2Document.Close[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    AcroApp.Exit[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set AcroApp = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set Part1Document = Nothing[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set Part2Document = Nothing[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    MsgBox "Done"[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub [/COLOR][/SIZE][/FONT]
 
Upvote 0
Hi,
To your PM - for me the reason of the problem is not in the file picker dialog.
Seems comma is used in file name of some your PDFs, but Split with comma separator has been used in the code.
Try this modification:
Rich (BB code):
Sub Main()
 
  Dim DestFile As String  ' <-- ZVI:2018-11-08
 
  Dim MyPath As String, MyFiles As String
  Dim a() As String, i As Long, f As String, Arr
 
  ' Choose the folder or just replace that part by: MyPath = Range("E3")
  With Application.FileDialog(msoFileDialogFolderPicker)
    '.InitialFileName = "D:\Dropbox\User\All Entities\Financials\Company A, LLC\"
    .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    MyPath = .SelectedItems(1)
    DoEvents
  End With
 
  ' Populate the array a() by PDF file names
  If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
 
  '--> ZVI:2018-11-08 Build DestFile using 2 last (sub)folders
  Arr = Split(MyPath, "\")
  If UBound(Arr) > 2 Then DestFile = Arr(UBound(Arr) - 1)
  If UBound(Arr) > 3 Then DestFile = Arr(UBound(Arr) - 2) & " - " & DestFile & " - "
  DestFile = DestFile & "Financial Statement.pdf"
  '<--
 
  ReDim a(1 To 2 ^ 14)
  f = Dir(MyPath & "*.pdf")
  While Len(f)
    If StrComp(f, DestFile, vbTextCompare) Then
      i = i + 1
      If Not LCase(f) Like "*.pdf" Then f = f & "*.pdf" ' <-- ZVI:2018-11-08
      a(i) = f
    End If
    f = Dir()
  Wend
 
  ' Merge PDFs
  If i Then
    ReDim Preserve a(1 To i)
    MyFiles = Join(a, vbTab)  ' <-- ZVI:2018-12-19
    Application.StatusBar = "Merging, please wait ..."
    Call MergePDFs(MyPath, MyFiles, DestFile)
    Application.StatusBar = False
  Else
    MsgBox "No PDF files found in" & vbLf & MyPath, vbExclamation, "Canceled"
  End If
 
End Sub
 
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
  ' ZVI:2013-08-27 http://www.vbaexpress.com/forum/showthread.php?47310-Need-code-to-merge-PDF-files-in-a-folder-using-adobe-acrobat-X
  ' Reference required: VBE - Tools - References - Acrobat XX.0 Type Library
 
  Dim a As Variant, i As Long, n As Long, ni As Long, p As String
  Dim AcroApp As New Acrobat.AcroApp, PartDocs() As Acrobat.CAcroPDDoc
 
  If Right(MyPath, 1) = "\" Then p = MyPath Else p = MyPath & "\"
  a = Split(MyFiles, vbTab) ' <-- ZVI:2018-12-19
  ReDim PartDocs(0 To UBound(a))
 
  On Error GoTo exit_
  If Len(Dir(p & DestFile)) Then Kill p & DestFile
  For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & a(i)) = "" Then        ' <-- ZVI:2018-11-08 Without Trim()
      MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled, i=" & i
      Exit For
    End If
    ' Open PDF document
    Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
    PartDocs(i).Open p & a(i)         '<--ZVI:2018-11-08 without Trim()
    If i Then
      ' Merge PDF to PartDocs(0) document
      ni = PartDocs(i).GetNumPages()
      If Not PartDocs(0).InsertPages(n - 1, PartDocs(i), 0, ni, True) Then
        MsgBox "Cannot insert pages of" & vbLf & p & a(i), vbExclamation, "Canceled"
        PartDocs(i).Close
        Set PartDocs(i) = Nothing
        Exit Sub
      End If
      ' Calc the number of pages in the merged document
      n = n + ni
      ' Release the memory
      PartDocs(i).Close
      Set PartDocs(i) = Nothing
    Else
      ' Calc the number of pages in PartDocs(0) document
      n = PartDocs(0).GetNumPages()
    End If
  Next
 
  If i > UBound(a) Then
    ' Save the merged document to DestFile
    If Not PartDocs(0).Save(PDSaveFull, p & DestFile) Then
      MsgBox "Cannot save the resulting document" & vbLf & p & DestFile, vbExclamation, "Canceled"
    End If
  End If
 
exit_:
 
  ' Inform about error/success
  If Err Then
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number
  ElseIf i > UBound(a) Then
    MsgBox "The resulting file is created:" & vbLf & p & DestFile, vbInformation, "Done"
  End If
 
  ' Release the memory
  If Not PartDocs(0) Is Nothing Then PartDocs(0).Close
  Set PartDocs(0) = Nothing
 
  ' Quit Acrobat application
  AcroApp.Exit
  Set AcroApp = Nothing
 
End Sub
 
Last edited:
Upvote 0
You are welcome! Glad we got it all sorted.
:beerchug:
 
Upvote 0

Forum statistics

Threads
1,223,908
Messages
6,175,306
Members
452,633
Latest member
DougMo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top