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

This is my understanding of your question:

Requirements:

• Combined a series of pdf files, located in the same folder of the workbook containing the procedure

• Pdf files names go from firstpdf1.pdf to firstpdfn.pdf where n is the total number of files to be combined

Let’s review your original code:

• All variables should be declared:

Dim objCAcroPDDocSource as object, objCAcroPDDocDestination as object

• This line is missing the path separator "\":

PDFfileName = Dir(ThisWorkbook.Path & "firstpdf" & n & ".pdf")

It should be PDFfileName = Dir(ThisWorkbook.Path & "\" & "firstpdf" & n & ".pdf")

• Therefore this line always returns "" (no pdf file was found in the ThisWorkbook.Path):

If PDFfileName <> "" Then

Additionally:

• These lines would have returned: Error - 424 Object required as the objects objCAcroPDDocSource and objCAcroPDDocDestination were not initialized:

objCAcroPDDocSource.Open ThisWorkbook.Path & "pathwithpdfs" & PDFfileName

If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then

objCAcroPDDocSource.Close

• The objCAcroPDDocDestination was never opened.

Solutions: These procedures use the Adobe Acrobat Library

Adobe Acrobat Library - Early bound

To create the Vb Reference to the Adobe Library in the VBA Editor menu click Tools`Referencesthen select theAdobe Acrobat Libraryin the dialog window then press theOK` button.

Sub PDFs_Combine_EarlyBound()
Dim PdfDst As AcroPDDoc, PdfSrc As AcroPDDoc
Dim sPdfComb As String, sPdf As String
Dim b As Byte

    Rem Set Combined Pdf filename - save the combined pdf in a new file in order to preserve original pdfs
    sPdfComb = ThisWorkbook.Path & "\" & "Pdf Combined" & Format(Now, " mmdd_hhmm ") & ".pdf"   'change as required

    Rem Open Destination Pdf
    b = 1
    sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
    Set PdfDst = New AcroPDDoc
    If Not (PdfDst.Open(sPdf)) Then
        MsgBox "Error opening destination pdf:" & vbCrLf _
            & vbCrLf & "[" & sPdf & "]" & vbCrLf _
            & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
        Exit Sub
    End If

    Do

        Rem Set & Validate Source Pdf
        b = b + 1
        sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
        If Dir(sPdf, vbArchive) = vbNullString Then Exit Do

        Rem Open Source Pdf
        Set PdfSrc = New AcroPDDoc
        If Not (PdfSrc.Open(sPdf)) Then
            MsgBox "Error opening source pdf:" & vbCrLf _
                & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
            GoTo Exit_Sub
        End If

        With PdfDst

            Rem Insert Source Pdf pages
            If Not (.InsertPages(-1 + .GetNumPages, PdfSrc, 0, PdfSrc.GetNumPages, 0)) Then
                MsgBox "Error inserting source pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            Rem Save Combined Pdf
            If Not (.Save(PDSaveFull, sPdfComb)) Then
                MsgBox "Error saving combined pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdfComb & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            PdfSrc.Close
            Set PdfSrc = Nothing

        End With

'        sPdf = Dir(sPdf, vbArchive)
'    Loop While sPdf <> vbNullString
    Loop

    MsgBox "Pdf files combined successfully!", vbExclamation

Exit_Sub:
    PdfDst.Close

   End Sub

Adobe Acrobat Library - Late bound

No need to create the Vb Reference to the Adobe Library

Sub PDFs_Combine_LateBound()
Dim PdfDst As Object, PdfSrc As Object
Dim sPdfComb As String, sPdf As String
Dim b As Byte

    Rem Set Combined Pdf filename - save the combined pdf in a new file in order to preserve original pdfs
    sPdfComb = ThisWorkbook.Path & "\" & "Pdf Combined" & Format(Now, " mmdd_hhmm ") & ".pdf"   'change as required

    Rem Open Destination Pdf
    b = 1
    sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
    Set PdfDst = CreateObject("AcroExch.PDDoc")
    If Not (PdfDst.Open(sPdf)) Then
        MsgBox "Error opening destination pdf:" & vbCrLf _
            & vbCrLf & "[" & sPdf & "]" & vbCrLf _
            & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
        Exit Sub
    End If

    Do

        Rem Set & Validate Source filename
        b = b + 1
        sPdf = ThisWorkbook.Path & "\" & "firstpdf" & b & ".pdf"
        If Dir(sPdf, vbArchive) = vbNullString Then Exit Do

        Rem Open Source filename
        Set PdfSrc = CreateObject("AcroExch.PDDoc")
        If Not (PdfSrc.Open(sPdf)) Then
            MsgBox "Error opening source pdf:" & vbCrLf _
                & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
            GoTo Exit_Sub
        End If

        With PdfDst

            Rem Insert Source filename pages
            If Not (.InsertPages(-1 + .GetNumPages, PdfSrc, 0, PdfSrc.GetNumPages, 0)) Then
                MsgBox "Error inserting source pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdf & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            Rem Save Combined Pdf
            If Not (.Save(1, sPdfComb)) Then
                MsgBox "Error saving combined pdf:" & vbCrLf _
                    & vbCrLf & "[" & sPdfComb & "]" & vbCrLf _
                    & vbCrLf & vbTab & "Procees will be cancelled!", vbCritical
                GoTo Exit_Sub
            End If

            PdfSrc.Close
            Set PdfSrc = Nothing

        End With

'        sPdf = Dir(sPdf, vbArchive)
'    Loop While sPdf <> vbNullString
    Loop

    MsgBox "Pdf files combined successfully!", vbExclamation

Exit_Sub:
    PdfDst.Close

   End Sub

Answer 2

You need to have adobe acrobat installed / operational.

I used this resource re method references

https://wwwimages2.adobe.com/content/dam/acom/en/devnet/acrobat/pdfs/iac_api_reference.pdf

EDIT: Swapping the array for auto generated (mostly, the primary pdf still set by user) list of pathways to pdfs that you want to insert into the primary pdf)

You can use something like below to generate the collection of documents to be inserted into your primary doc. The first file in the collection would be the file that you are inserting into, same as in first example. Then assign the folder pathway of the folder with the pdf files that you would like to see inserted into your primary doc to inputDirectoryToScanForFile. The loop in this code will add the pathway of every pdf file in that folder to your collection. These are the pathways later used in the adobe API calls to insert pdf into your primary.

Sub main()

Dim myCol                               As Collection
Dim strFile                             As String
Dim inputDirectoryToScanForFile         As String
Dim primaryFile                         As String

    Set myCol = New Collection

    primaryFile = "C:\Users\Evan\Desktop\myPDf.Pdf"

    myCol.Add primaryFile

    inputDirectoryToScanForFile = "C:\Users\Evan\Desktop\New Folder\"

    strFile = Dir(inputDirectoryToScanForFile & "*.pdf")

    Do While strFile <> ""
        myCol.Add strFile
        strFile = Dir
    Loop
End Sub

Code that takes a primary file and inserts other pdfs into that file:

Sub main()

    Dim arrayFilePaths() As Variant
    Set app = CreateObject("Acroexch.app")

    arrayFilePaths = Array("C:\Users\Evan\Desktop\PAGE1.pdf", _
                            "C:\Users\Evan\Desktop\PAGE2.pdf", _
                            "C:\Users\Evan\Desktop\PAGE3.pdf")

    Set primaryDoc = CreateObject("AcroExch.PDDoc")
    OK = primaryDoc.Open(arrayFilePaths(0))
    Debug.Print "PRIMARY DOC OPENED & PDDOC SET: " & OK

    For arrayIndex = 1 To UBound(arrayFilePaths)
        numPages = primaryDoc.GetNumPages() - 1

        Set sourceDoc = CreateObject("AcroExch.PDDoc")
        OK = sourceDoc.Open(arrayFilePaths(arrayIndex))
        Debug.Print "SOURCE DOC OPENED & PDDOC SET: " & OK

        numberOfPagesToInsert = sourceDoc.GetNumPages

        OK = primaryDoc.InsertPages(numPages, sourceDoc, 0, numberOfPagesToInsert, False)
        Debug.Print "PAGES INSERTED SUCCESSFULLY: " & OK

        OK = primaryDoc.Save(PDSaveFull, arrayFilePaths(0))
        Debug.Print "PRIMARYDOC SAVED PROPERLY: " & OK

        Set sourceDoc = Nothing
    Next arrayIndex

    Set primaryDoc = Nothing
    app.Exit
    Set app = Nothing
    MsgBox "DONE"
End Sub

Answer 3

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

Answer 4

I don't have a exact soluation for your problem, however, I had a similar one, namely that I wanted to add fields to a pdf from VBA.

I can tell you that Adobe has a JavaScript API which you can control through vba.

Here is the link to the API https://www.adobe.com/devnet/acrobat/javascript.html

And this is a part of the code I used in VBA to control fields in the PDFs.

Set app = CreateObject("Acroexch.app")
app.Show
Set AVDoc = CreateObject("AcroExch.AVDoc")
Set AForm = CreateObject("AFormAut.App") 'from AFormAPI
AVDoc.Open(pathsdf, "")

Ex = "Put your JavaScript Code here"

AForm.Fields.ExecuteThisJavaScript Ex

You should probably look at the insertPages method in the API.

What is als possible is using the build in reference from VBA to Acrobat. However, I found it very limited and I did not work with it. There are only a few objects available, here are some examples:

Dim AcroApp As Acrobat.AcroApp
Dim objAcroAVDoc As New Acrobat.AcroAVDoc
Dim objAcroPDDoc As Acrobat.AcroPDDoc
Dim objAcroPDPage As Acrobat.AcroPDPage
Dim annot As Acrobat.AcroPDAnnot