Merging pdfs with parent / child bookmarks
I found some code on Stack OverFlow that allows me to combine pdfs and insert bookmarks - which is pretty close to exactly what i needed:
however it does not completely satisfy our needs.
The code does create a blank pdf and inserts pages and bookmarks for each section inserted, but it does not take bring in bookmarks from the original pdf's as children to the bookmarks it is creating.
Example:
I have 3 pdfs.
Name Desired BookMark Name
1.PDF Cover Page (2 pages)
2.PDF Test Reports (8 pages) (which has 2 bookmarks inside of it - ABC on page 3 and XYZ on page 8
3.PDF Operating Manual (6 pages)
the first part of my code below builds a 2 dimensional array with the filename and desired bookmark name.
the code below does create a new pdf with the 3 files and creates bookmarks
new.pdf
Cover Page (Page 1)
Test Reports (Page 3)
Operating Manual (Page 11)
what i need is the following:
new.pdf
Cover Page (Page 1)
Test Reports (Page 3)
ABC (Page 5)
XYZ (Page 😎
Operating Manual (Page 11)
any help would be greatly appreciated.
----Start of Code
' This Sub is attached to a button on a form in access that opens a query and builds a 2 dimensional array with the FileNames and BookMark Names
Private Sub BuildDatabook_Click()
On Error GoTo Err_BuildDatabook_Click
Dim sqlStr As String
Dim rst As DAO.Recordset
Dim vFiles() As String
Dim iNrOfFiles As Long
Dim iNrOfIncorrectFiles As Long
Dim sPDFFileName As String
Dim sPDFBookMark As String
Dim sNewPDFFileName As String
sNewPDFFileName = "C:\Test\" & Me.Order_ID & "_" & Format(Now(), "YYYYMMDDhhnn") & ".pdf"
iNrOfFiles = 0
iNrOfIncorrectFiles = 0
sqlStr = "SELECT * FROM Document_Reference_DataBook_Build_Pdf WHERE Order_ID = '" & Me.Order_ID & "'"
Set rst = CurrentDb.OpenRecordset(sqlStr)
Do While Not rst.EOF
sPDFFileName = rst("FileName")
sPDFBookMark = rst("BookMark")
If Len(Dir(sPDFFileName)) = 0 Then
MsgBox "File Does Not Exist: " & sPDFFileName
'do not add to array
iNrOfIncorrectFiles = iNrOfIncorrectFiles + 1
Else
ReDim Preserve vFiles(1, iNrOfFiles)
vFiles(0, iNrOfFiles) = sPDFFileName
vFiles(1, iNrOfFiles) = sPDFBookMark
iNrOfFiles = iNrOfFiles + 1
End If
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
MsgBox "iNrOfFiles: " & iNrOfFiles & " iNrOfIncorrectFiles: " & iNrOfIncorrectFiles
If iNrOfFiles > 0 Then
If iNrOfIncorrectFiles = 0 Then
updfConcatenate vFiles, sNewPDFFileName
Else
updfConcatenate vFiles, sNewPDFFileName
MsgBox sNewPDFFileName & " File Created, but " & iNrOfIncorrectFiles & " file(s) could not be found."
End If
Else
MsgBox "No valid files found to be merged", vbInformation, "Build Databook PDF"
End If
Exit_BuildDatabook_Click:
Exit Sub
Err_BuildDatabook_Click:
MsgBox err.Description
Resume Exit_BuildDatabook_Click
End Sub
_______
Sub updfConcatenate(pvarFromPaths() As String, pstrToPath As String)
' this sub inserts the pages and calls the next sub to take care of the bookmarks
'Dim mlngBkmkCounter As Long put in under option comparer database
Dim origPdfDoc As Acrobat.CAcroPDDoc
Dim newPdfDoc As Acrobat.CAcroPDDoc
Dim lngNewPageCount As Long
Dim lngInsertPage As Long
Dim i As Long
'On Error GoTo ExitHere
Set origPdfDoc = CreateObject("AcroExch.PDDoc")
Set newPdfDoc = CreateObject("AcroExch.PDDoc")
'set the first file in the array as the "new" original value was updfInsertBookmark
If newPdfDoc.Open(pvarFromPaths(0, 0)) = True Then
updfInsertBookmark pvarFromPaths(1, 0), lngInsertPage, , newPdfDoc
mlngBkmkCounter = 1
For i = 1 To UBound(pvarFromPaths, 2)
' MsgBox "Merging " & pvarFromPaths(0, i) & "..."
If origPdfDoc.Open(pvarFromPaths(0, i)) = True Then
lngInsertPage = newPdfDoc.GetNumPages
newPdfDoc.InsertPages lngInsertPage - 1, origPdfDoc, 0, origPdfDoc.GetNumPages, False
'insert a bookmark - if a name was provided and not empty
If pvarFromPaths(1, i) <> "" Then
updfInsertBookmark pvarFromPaths(1, i), lngInsertPage, , newPdfDoc
mlngBkmkCounter = mlngBkmkCounter + 1
End If
origPdfDoc.Close
End If
Next i
MsgBox "save pdf to:" & pstrToPath
newPdfDoc.Save PDSaveFull, pstrToPath
End If
ExitHere:
Set origPdfDoc = Nothing
Set newPdfDoc = Nothing
'MsgBox "Failed!", vbInformation , "Build Databooks"
Exit Sub
End Sub
-------------
Public Sub updfInsertBookmark(pstrCaption As String, plngPage As Long, _
'this is the sub that inserts bookmarks - this is where i need some help
Optional pstrPath As String, _
Optional pMyPDDoc As Acrobat.CAcroPDDoc, _
Optional plngIndex As Long = -1, _
Optional plngParentIndex As Long = -1)
Dim MyPDDoc As Acrobat.CAcroPDDoc
Dim jso As Object
Dim BMR As Object
Dim arrParents As Variant
Dim bkmChildsParent As Object
Dim bleContinue As Boolean
Dim bleSave As Boolean
Dim lngIndex As Long
If pMyPDDoc Is Nothing Then
Set MyPDDoc = CreateObject("AcroExch.PDDoc")
bleContinue = MyPDDoc.Open(pstrPath)
bleSave = True
Else
Set MyPDDoc = pMyPDDoc
bleContinue = True
End If
If plngIndex > -1 Then
lngIndex = plngIndex
Else
lngIndex = mlngBkmkCounter
End If
If bleContinue = True Then
Set jso = MyPDDoc.GetJSObject
Set BMR = jso.bookmarkRoot
If plngParentIndex > -1 Then
arrParents = jso.bookmarkRoot.Children
Set bkmChildsParent = arrParents(plngParentIndex)
bkmChildsParent.createchild pstrCaption, "this.pageNum= " & plngPage, lngIndex
Else
BMR.createchild pstrCaption, "this.pageNum= " & plngPage, lngIndex
End If
MyPDDoc.SetPageMode 3 '3 — display using bookmarks'
If bleSave = True Then
MyPDDoc.Save PDSaveIncremental, pstrPath
MyPDDoc.Close
End If
End If
ExitHere:
Set jso = Nothing
Set BMR = Nothing
Set arrParents = Nothing
Set bkmChildsParent = Nothing
Set MyPDDoc = Nothing
End Sub
----End of Code
AdChoices