Naming bookmarks in PDF with VBA no longer working

[mrweiss]

Hi everyone - I have a workbook that takes Excel files saved as PDFs merges them and then adds and names bookmarks to each individual PDF. Previously, the bookmarks were named based on a range in the source file, but now they are just left as "Untitled". I've tried for days to troubleshoot. The names for all the bookmarks are still in the same place as they have always been. Nothing about the source file has been changed. Code below. Any help would be greatly appreciated!

Public BookMarkName() As String
Public BookMarkPageNumber() As Integer
Public BookMarkArrayNumber As Integer
Sub MergeFiles()
'
'
Application.ScreenUpdating = True

Dim cl As Range
Dim SheetRange() As Variant
Dim MyPath As String, MyFiles As String
Dim a() As String, i As Long, f As String
Dim DestFile As String

Dim AcroApp As Acrobat.CAcroApp
Dim PDoc As Acrobat.CAcroPDDoc
Dim ADoc As AcroAVDoc
Dim PDBookmark As AcroPDBookmark
Dim PDFPageView As AcroAVPageView
Dim AcroDoc As Object


Set PDBookmark = CreateObject("AcroExch.PDBookmark", "")
Set AcroApp = CreateObject("AcroExch.App")
Set PDoc = CreateObject("AcroExch.PDDoc")
Set ADoc = CreateObject("AcroExch.AVDoc")
Set BlankPDF = CreateObject("AcroExch.PDDoc")


Set PageCount = New Acrobat.AcroPDDoc

Template = ActiveWorkbook.Name
CurrentSheet = ActiveSheet.Name

DestFile = Workbooks(Template).Sheets(CurrentSheet).Range("D5").Value
MyPath = Workbooks(Template).Sheets(CurrentSheet).Range("D2").Value

LastRowModels = Workbooks(Template).Sheets(CurrentSheet).Cells(Workbooks(Template).Sheets(CurrentSheet).Rows.Count, "A").End(xlUp).Row

BookMarkArrayNumber = 0

'Save of Blank Page for later use
If Workbooks(Template).Sheets(CurrentSheet).Range("G1").Value = "Y" Then
Workbooks.Add
NewBook = ActiveWorkbook.Name
NewSheet = ActiveSheet.Name

Workbooks(NewBook).Sheets(NewSheet).Range("A1").Value = " "

'Save off selected tabs as PDF
If Right(MyPath, 1) <> "\" Then SaveLocation = MyPath & "\"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
SaveLocation & "Blank.pdf", Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

Workbooks(NewBook).Close False
End If

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

'Add Models to Array
If Workbooks(Template).Sheets(CurrentSheet).Range("A2") <> "" Then
For Each cl In Workbooks(Template).Sheets(CurrentSheet).Range("A2:A" & LastRowModels)
BlankPage = False
i = i + 1
ModelName = Right(Left(cl.Value, InStr(1, cl.Value, ".xl") - 1), Len(Left(cl.Value, InStr(1, cl.Value, ".xl") - 1)) - InStrRev(Left(cl.Value, InStr(1, cl.Value, ".xl") - 1), "\", -1))
a(i) = ModelName & ".pdf"

FileLocationPath = MyPath & ModelName & ".pdf"
PageCount.Open FileLocationPath

NumofPages = PageCount.GetNumPages

If Workbooks(Template).Sheets(CurrentSheet).Range("G1").Value = "Y" Then
If NumofPages Mod 2 Then
i = i + 1
a(i) = "Blank.pdf"
BlankPage = True
End If
End If

ReDim Preserve BookMarkName(0 To BookMarkArrayNumber)
ReDim Preserve BookMarkPageNumber(0 To BookMarkArrayNumber)
BookMarkName(BookMarkArrayNumber) = Workbooks(Template).Sheets(CurrentSheet).Range("B" & cl.Row)

If BlankPage = False Then
BookMarkPageNumber(BookMarkArrayNumber) = NumofPages
Else
BookMarkPageNumber(BookMarkArrayNumber) = NumofPages + 1
End If

BookMarkArrayNumber = BookMarkArrayNumber + 1

PageCount.Close
Next cl
End If

' 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

'Add Bookmarks
PDoc.Open (MyPath & DestFile)
Set ADoc = PDoc.OpenAVDoc(MyPath & "\" & DestFile)
Set PDFPageView = ADoc.GetAVPageView()

On Error Resume Next
AppActivate "Adobe Acrobat Pro"
If Err.Number <> 0 Then
AppActivate "Adobe Acrobat Pro DC"
End If

PageNumber = 0
BookMarkArrayNumber = BookMarkArrayNumber - 1

For i = 0 To BookMarkArrayNumber
Call PDFPageView.GoTo(PageNumber)
AcroApp.MenuItemExecute ("NewBookmark")
btitle = PDBookmark.GetByTitle(PDoc, "Untitled")
btitle = PDBookmark.SetTitle(BookMarkName(i))
PageNumber = PageNumber + BookMarkPageNumber(i)
Next i

'Show Bookmark Panel
ShowBookMarks = PDoc.SetPageMode(3)

'Save and CLose
WasSaved = PDoc.Save(PDSaveFull, MyPath & DestFile)
PDoc.Close

AcroApp.Exit

Set AcroApp = Nothing
Set PDoc = Nothing
Set ADoc = Nothing

'Delete Blank File
Kill MyPath & "Blank.pdf"

Application.ScreenUpdating = True

MsgBox "Great Success!"

End Sub
Sub MergePDFs(MyPath As String, MyFiles As String, Optional DestFile As String = "MergedFile.pdf")
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
Dim JSO As Object, BookMarkRoot As Object
Dim objCAcroPDDocDestination 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(p & 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, 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
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

 

[John_w]

You have many undeclared variables. I suggest you put Option Explicit at the top of the module, recompile and add Dim statements for the undeclared variables until it compiles successfully.