VBA, Combine PDFs into one PDF file

Question

I am trying to combine PDF\'s into one single pdf with the use of vba. I would like to not use a plug in tool and have tried with acrobat api below.

I have tried som

Answer 1

The below code i got from stack overflow this will list all sub folders in a folder.

Sub FolderNames()
'Update 20141027
Application.ScreenUpdating = False
Dim xPath As String
Dim xWs As Worksheet
Dim fso As Object, j As Long, folder1 As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
'Application.Workbooks.Add
Set xWs = Application.ActiveSheet
Sheets("Sheet1").Cells.Clear
xWs.Cells(1, 1).Value = xPath
xWs.Cells(2, 1).Resize(1, 5).Value = Array("Path", "Dir", "Name", "Date Created",            "Date Last Modified")
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder1 = fso.GetFolder(xPath)
getSubFolder folder1
xWs.Cells(2, 1).Resize(1, 5).Interior.Color = 65535
xWs.Cells(2, 1).Resize(1, 5).EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
For Each SubFolder In prntfld.SubFolders
xRow = Range("A1").End(xlDown).Row + 1
Cells(xRow, 1).Resize(1, 5).Value = Array(SubFolder.Path, Left(SubFolder.Path,       InStrRev(SubFolder.Path, "\")), SubFolder.Name, SubFolder.DateCreated, SubFolder.DateLastModified)
Next SubFolder
For Each subfld In prntfld.SubFolders
getSubFolder subfld
Next subfld
End Sub

This Code will Combine all PDF files in sub-folder and stores the output in chosen destination folder

Sub Merger()
Dim i As Integer
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim k As Integer
Dim st As String
Dim na As String
Dim dest As String

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the Destination folder"
.Show
End With
dest = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"


k = sh.Range("A1048576").End(xlUp).Row
For i = 3 To k
st = sh.Cells(i, 1).Value
na = sh.Cells(i, 3).Value
Call Main(st, na, dest)
Next

 MsgBox "The resulting files are created" & vbLf & p & DestFile, vbInformation, "Done"

End Sub

Sub Main(ByVal st As String, ByVal na As String, dest As String)

Dim DestFile As String
DestFile = "" & dest & na & ".pdf" ' <-- change TO Your Required Desitination

Dim MyPath As String, MyFiles As String
Dim a() As String, i As Long, f As String
Dim R As Range
Dim ws As Worksheet
Dim n As Long



 ' Choose the folder or just replace that part by: MyPath = Range("E3")
With Application.FileDialog(msoFileDialogFolderPicker)
     '.InitialFileName = "C:\Temp\"
    .AllowMultiSelect = True
    'If .Show = False Then Exit Sub
    MyPath = st
    DoEvents
End With

  ' Populate the array a() by PDF file names
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\"
ReDim a(1 To 2 ^ 14)

f = Dir(MyPath & "*")
While Len(f)
    If StrComp(f, DestFile, vbTextCompare) Then
        i = i + 1
        a(i) = f
        'a().Sort
    End If
    f = Dir()
Wend

'SORTING--------------------------------------------------------

Set ws = ThisWorkbook.Sheets("Sheet2")

' put the array values on the worksheet
Set R = ws.Range("A1").Resize(UBound(a) - LBound(a) + 1, 1)
R = Application.Transpose(a)

' sort the range
R.Sort key1:=R, order1:=xlAscending, MatchCase:=False

' load the worksheet values back into the array
For n = 1 To R.Range("A1048576").End(xlUp).Row
    a(n) = R(n, 1)
Next n

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

'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

Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String)
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, ",")
ReDim PartDocs(0 To UBound(a))

On Error GoTo exit_
If Len(Dir(DestFile)) Then Kill p & DestFile
For i = 0 To UBound(a)
    ' Check PDF file presence
    If Dir(p & Trim(a(i))) = "" Then
        MsgBox "File not found" & vbLf & p & a(i), vbExclamation, "Canceled"
        Exit For
    End If
    ' Open PDF document
    Set PartDocs(i) = CreateObject("AcroExch.PDDoc")
    PartDocs(i).Open p & Trim(a(i))
    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, 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