Create PDF bookmarks while combinding files with VBA in Excel

[dchaney]

Hello all,

I currently have multiple folders with PDF files in them, I have found and tweaked the following code to combine the PDF files within each folder into a single document (which is what I need it to do). However, what I can not figure out is how to add Bookmarks for each new file added, please review the below code and help if possible. I am a novice at best on VBA coding and teaching myself as I go.

Sub MoveFiles() 'Designed to move files in a folder based on the information in an excel file (BP R05 - L01 Material Certs)
'
'-------------------------------------------------------------------------------
'Must have an Excel spredsheet with the following headers on Row 8: A8 = PES Group, B8 = Part Number, C8 = Keyword, D8 = Subtitle, F8 = Serial No., G8 = Doc. No., I8 = Pages
'Important columns are B, F, G and I
'Each parent row must be shaded grey (ColorIndex 15) which is the 4th grey from the bottom of the fill color table
'-------------------------------------------------------------------------------
'
Dim FromPath As String, ToPath As String, FolderName As String, FileName As String
Dim lastRow As Long
Dim FSO As Object

'Turn off Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
On Error Resume Next

Set FSO = CreateObject("scripting.filesystemobject")

'Select the folder that stores the files you wish to move
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    DialogFolder.InitialFileName = ActiveWorkbook.Path
    If DialogFolder.Show = -1 Then
        FromPath = DialogFolder.SelectedItems(1) & "\"
    Else: Set DialogFolder = Nothing
    End If
    
Set DialogFolder = Nothing

lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Move files into folders per information found on excel spread sheet as listed above
i = 9

Do Until i > lastRow

FolderName = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\" 'sets the foldername inwhich the files will be moved to
ToPath = FromPath & FolderName 'Set the path to move the files to
FileName = Cells(i, 7) & "_REV000.pdf" 'name of the file to move into the ToPath location

'Cells(1, 15) = FromPath

If Cells(i, 1).Interior.ColorIndex = 15 Then
        ParentFolder = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\" 'create the value for the ParentFolder
        FSO.MoveFile Source:=FromPath & FileName, Destination:=FromPath & ParentFolder 'move the Parent File into the ParentFolder
    i = i + 1
ElseIf Cells(i, 1).Interior.ColorIndex <> 15 Then
        FSO.CopyFile Source:=FromPath & FileName, Destination:=FromPath & ParentFolder
    i = i + 1
End If

Loop

Set FSO = Nothing

Kill FromPath & "*.pdf" 'Deletes all pdf files that remain on the FromPath directory

MsgBox "All files have been moved, you may go about your merry day :)"

'Turn on Application Functions
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
End Sub

 

[dchaney]

The above code is the one I use to move the files to a different folder, I am sorry, My question from above is based on this code:

Private Sub Command0_Click()
'
'
'
'Relies on the Adobe Acrobat 6.0 Type Library
Dim FromPath As String, ToPath As String, FolderName As String, FileName As String
Dim ParentFolder As String, ParentFile As String
Dim avdoc As Object, pddoc As Object, app As Object
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim PDBookmark As CAcroPDBookmark
Dim btitle As Boolean
Dim lastRow As Long


'Initialize the objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")

lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Select the proper from directory
Set DialogFolder = Application.FileDialog(msoFileDialogFolderPicker)
    DialogFolder.InitialFileName = ActiveWorkbook.path
    If DialogFolder.Show = -1 Then
        FromPath = DialogFolder.SelectedItems(1) & "\"
    Else: Set DialogFolder = Nothing
    End If
    
Set DialogFolder = Nothing

'Identify folder and document names
i = 9

Do Until i > lastRow

FolderName = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\"
ToPath = FromPath & FolderName
FileName = Cells(i, 7) & "_REV000.pdf"

'Cells(1, 15) = FromPath

If Cells(i, 1).Interior.ColorIndex = 15 Then
        ParentFolder = i - 8 & " - " & Cells(i, 2) & " - " & Cells(i, 6) & "\"
        ParentFile = Cells(i, 7) & "_REV000.pdf"
    i = i + 1
ElseIf Cells(i, 1).Interior.ColorIndex <> 15 Then
        objCAcroPDDocDestination.Open (FromPath & ParentFolder & ParentFile) 'Open Destination, all other documents will be added to this and saved with a new filename
        objCAcroPDDocSource.Open (FromPath & ParentFolder & FileName) 'Open the source document that will be added to the destination
            If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
                 objCAcroPDDocDestination.Save 1, (FromPath & ParentFolder & ParentFile)
                objCAcroPDDocSource.Close
                'MsgBox "Documents Merged!"
            End If
    i = i + 1
End If

Loop


objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
End Sub

 

[John_w]

Try replacing:

                If objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
                     objCAcroPDDocDestination.Save 1, (FromPath & ParentFolder & ParentFile)
                    objCAcroPDDocSource.Close
                    'MsgBox "Documents Merged!"
                End If

with:

    Dim insertSuccess As Boolean
    Dim n As Long, p As Long
    Dim JSO As Object, BookMarkRoot As Object
                
            p = objCAcroPDDocDestination.GetNumPages
            insertSuccess = objCAcroPDDocDestination.InsertPages(p - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0)
            
            If insertSuccess Then
                n = n + 1
                Set BookMarkRoot = JSO.BookMarkRoot
                BookMarkRoot.createchild "Bookmark " & n & " Page " & p + 1, "this.pageNum=" & p, n
            End If
            
            objCAcroPDDocDestination.Save 1, FromPath & ParentFolder & ParentFile
            objCAcroPDDocSource.Close

Change the bookmark text as required.

 

[dchaney]

Hello John,

Thank you for the response, the I am getting an error (Object Variable or With block variable not set) on "Set BookMarkRoot = JSO.BookMarkRoot" is there any additional reference sets I need to have checked to use this or is there another issue I am not seeing by chance?

 

[John_w]

Sorry, I missed a line when transferring the code to your scenario. Immediately before that line, add the following:

    Set JSO = objCAcroPDDocDestination.GetJSObject

 

[dchaney]

Thanks a lot, your code worked great, only issue I have now, is that if the original file contains bookmarks, the new bookmark is not placed at the end of the list as it should be for the merge. I am working on that, but if there is anything you can do to assist that would be amazing.

Again thank you for your help on this

 

[John_w]

That happens because the variable 'n' as the bookmark index (the last argument of BookmarkRoot.createChild) is given the values 1, 2, 3, etc., so the new bookmarks are inserted after the 0 bookmark index. Try this replacement code, along the same lines as post #3, which inserts the new bookmarks after the last bookmark.

    Dim insertSuccess As Boolean
    Dim n As Long, p As Long
    Dim JSO As Object, BookmarkRoot As Object
                
            p = objCAcroPDDocDestination.GetNumPages
            insertSuccess = objCAcroPDDocDestination.InsertPages(p - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0)
            
            If insertSuccess Then
                Set JSO = objCAcroPDDocDestination.GetJSObject
                Set BookmarkRoot = JSO.BookmarkRoot
                n = UBound(BookmarkRoot.Children) + 1
                BookmarkRoot.createChild "Bookmark " & n & " Page " & p + 1, "this.pageNum=" & p, n
            End If
            
            objCAcroPDDocDestination.Save 1, FromPath & ParentFolder & ParentFile
            objCAcroPDDocSource.Close

 

[dchaney]

Ohhhh, look at that, this is great... Thank you John_w

One last question you may be able to help with, I have hundreds of PDFs and some have generic bookmarks and others do not, I want to clear ALL bookmarks and then start fresh with this code you help me with. Any idea how to do that? If not that is great, you have helped me out a LOT and I thank you for it...

 

[John_w]

    BookmarkRoot.Remove

deletes all bookmarks in the open document.

To scan through all files in a folder tree, use a recursive FileSystemObject procedure (search this forum for examples), checking for file name ending ".pdf", and open and save each PDF file using the Acrobat objects and methods used in this thread. You might want to test it first on a copy or partial copy of your folder tree.

 

[dchaney]

I was close, I was trying BookmarkRoot.Delete.. again thank you so very much