Include a BOOKMARK in an Access report so PDF will recognize it later

Oh, it would be much easier to print individual reports from Access.  It is pretty simple in fact.  You have a report with all of the information you need in it and you open it by iterating through a recordset of individuals and changing the querydef for the report so you can output it to a particular file name.

Oh, and here's the code I use to create the pdf, merge them, and then add bookmarks.  Like I said it would take some messing around with to fit it to your situation:

Option Compare Database
Option Explicit

'===========================================================
' Code begins here
'
' The function to call is RunReportAsPDF
'
' It requires 2 parameters:  the Access Report to run
'                            the PDF file name
'
' Enjoy!
'
' Eric Provencher
'===========================================================

Private Declare Sub CopyMemory Lib "kernel32" _
              Alias "RtlMoveMemory" (dest As Any, _
                                     Source As Any, _
                                     ByVal numBytes As Long)

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
                  Alias "RegOpenKeyExA" (ByVal hKey As Long, _
                                         ByVal lpSubKey As String, _
                                         ByVal ulOptions As Long, _
                                         ByVal samDesired As Long, _
                                         phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
                   Alias "RegCreateKeyExA" (ByVal hKey As Long, _
                                            ByVal lpSubKey As String, _
                                            ByVal Reserved As Long, _
                                            ByVal lpClass As String, _
                                            ByVal dwOptions As Long, _
                                            ByVal samDesired As Long, _
                                            ByVal lpSecurityAttributes As Long, _
                                            phkResult As Long, _
                                            lpdwDisposition As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
                   Alias "RegQueryValueExA" (ByVal hKey As Long, _
                                             ByVal lpValueName As String, _
                                             ByVal lpReserved As Long, _
                                             lpType As Long, _
                                             lpData As Any, _
                                             lpcbData As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" _
                   Alias "RegSetValueExA" (ByVal hKey As Long, _
                                           ByVal lpValueName As String, _
                                           ByVal Reserved As Long, _
                                           ByVal dwType As Long, _
                                           lpData As Any, _
                                           ByVal cbData As Long) As Long

Private Declare Function apiFindExecutable Lib "shell32.dll" _
                  Alias "FindExecutableA" (ByVal lpFile As String, _
                                           ByVal lpDirectory As String, _
                                           ByVal lpResult As String) As Long

Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234

Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002

Const KEY_ALL_ACCESS = &HF003F
Const REG_OPTION_NON_VOLATILE = 0
Const PDSaveCopy = 2
Const KEY_READ = &H20019  ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
                          ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
                          ' SYNCHRONIZE))

Const KEY_WRITE = &H20006  '((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or
                           ' KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
                          
                          
Const TOC As String = "tbltmpTableOfContents"

Public Function RunReportAsPDF(prmRptName As String, _
                               prmPdfName As String) As Long

' Returns TRUE if a PDF file has been created

    Dim AdobeDevice As String
    Dim strDefaultPrinter As String
    Dim blnFlag As Boolean
    'Find the Acrobat PDF device
    'HCPath
    AdobeDevice = GetRegistryValue(HKEY_CURRENT_USER, _
                                   "Software\Microsoft\WIndows NT\CurrentVersion\Devices", _
                                   "Adobe PDF")

    If AdobeDevice = "" Then    ' The device was not found
        MsgBox "You must install Acrobat Writer before using this feature"
        RunReportAsPDF = False
        Exit Function
    End If

    ' get current default printer.
    strDefaultPrinter = Application.Printer.DeviceName

    Set Application.Printer = Application.Printers("Adobe PDF")

    'Create the Registry Key where Acrobat looks for a file name
    'HCPath
    CreateNewRegistryKey HKEY_CURRENT_USER, _
                         "Software\Adobe\Acrobat Distiller\PrinterJobControl"

    'Put the output filename where Acrobat could find it
    'HCPath
    SetRegistryValue HKEY_CURRENT_USER, _
                     "Software\Adobe\Acrobat Distiller\PrinterJobControl", _
                     Find_Exe_Name(CurrentDb.Name, CurrentDb.Name), _
                     prmPdfName

    On Error GoTo Err_handler

    DoCmd.OpenReport prmRptName, acViewNormal   'Run the report

    While Len(Dir(prmPdfName)) = 0              ' Wait for the PDF to actually exist
        DoEvents
    Wend

    RunReportAsPDF = True       ' Mission accomplished!

Normal_Exit:

    Set Application.Printer = Application.Printers(strDefaultPrinter)   ' Restore default printer

    On Error GoTo 0

    Exit Function

Err_handler:

    Select Case Err.Number
    Case 2501         ' The report did not run properly (ex NO DATA)
        RunReportAsPDF = 2
        Resume Normal_Exit

    Case 2212    ' Can't print this object
        If blnFlag = False Then
            blnFlag = True
            RunReportAsPDF = 3
            Resume Normal_Exit
        End If
    Case Else
        RunReportAsPDF = False      ' The report did not run properly (anything else!)
        MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
        Resume Normal_Exit
    End Select

End Function

Public Function Find_Exe_Name(prmFile As String, _
                              prmDir As String) As String

Dim Return_Code As Long
Dim Return_Value As String

Return_Value = Space(260)
Return_Code = apiFindExecutable(prmFile, prmDir, Return_Value)

If Return_Code > 32 Then
    Find_Exe_Name = Return_Value
Else
    Find_Exe_Name = "Error: File Not Found"
End If

End Function

Public Sub CreateNewRegistryKey(prmPredefKey As Long, _
                                prmNewKey As String)

' Example #1:  CreateNewRegistryKey HKEY_CURRENT_USER, "TestKey"
'
'              Create a key called TestKey immediately under HKEY_CURRENT_USER.
'
' Example #2:  CreateNewRegistryKey HKEY_LOCAL_MACHINE, "TestKey\SubKey1\SubKey2"
'
'              Creates three-nested keys beginning with TestKey immediately under
'              HKEY_LOCAL_MACHINE, SubKey1 subordinate to TestKey, and SubKey3 under SubKey2.
'
Dim hNewKey As Long         'handle to the new key
Dim lRetVal As Long         'result of the RegCreateKeyEx function

lRetVal = RegOpenKeyEx(prmPredefKey, prmNewKey, 0, KEY_ALL_ACCESS, hNewKey)

If lRetVal <> 5 Then
    lRetVal = RegCreateKeyEx(prmPredefKey, prmNewKey, 0&, _
                             vbNullString, REG_OPTION_NON_VOLATILE, _
                             KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
End If

RegCloseKey (hNewKey)

End Sub

Function GetRegistryValue(ByVal hKey As Long, _
                          ByVal KeyName As String, _
                          ByVal ValueName As String, _
                          Optional DefaultValue As Variant) As Variant

Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
   
' Read a Registry value
'
' Use KeyName = "" for the default value
' If the value isn't there, it returns the DefaultValue
' argument, or Empty if the argument has been omitted
'
' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ
' REG_MULTI_SZ values are returned as a null-delimited stream of strings
' (VB6 users can use SPlit to convert to an array of string)

   
' Prepare the default result
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)

' Open the key, exit if not found.
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
    Exit Function
End If

' prepare a 1K receiving resBinary
length = 1024
ReDim resBinary(0 To length - 1) As Byte

' read the registry key
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)

' if resBinary was too small, try again
If retVal = ERROR_MORE_DATA Then
    ' enlarge the resBinary, and read the value again
    ReDim resBinary(0 To length - 1) As Byte
    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
        length)
End If

' return a value corresponding to the value type
Select Case valueType
    Case REG_DWORD
        CopyMemory resLong, resBinary(0), 4
        GetRegistryValue = resLong
    Case REG_SZ, REG_EXPAND_SZ
        ' copy everything but the trailing null char
        resString = Space$(length - 1)
        CopyMemory ByVal resString, resBinary(0), length - 1
        GetRegistryValue = resString
    Case REG_BINARY
        ' resize the result resBinary
        If length <> UBound(resBinary) + 1 Then
            ReDim Preserve resBinary(0 To length - 1) As Byte
        End If
        GetRegistryValue = resBinary()
    Case REG_MULTI_SZ
        ' copy everything but the 2 trailing null chars
        resString = Space$(length - 2)
        CopyMemory ByVal resString, resBinary(0), length - 2
        GetRegistryValue = resString
    Case Else
        GetRegistryValue = ""
'        RegCloseKey handle
'        Err.Raise 1001, , "Unsupported value type"
End Select

RegCloseKey handle  ' close the registry key
   
End Function

Function SetRegistryValue(ByVal hKey As Long, _
                          ByVal KeyName As String, _
                          ByVal ValueName As String, _
                          Value As Variant) As Boolean
                         
' Write or Create a Registry value
' returns True if successful
'
' Use KeyName = "" for the default value
'
' Value can be an integer value (REG_DWORD), a string (REG_SZ)
' or an array of binary (REG_BINARY). Raises an error otherwise.

Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim byteValue As Byte
Dim length As Long
Dim retVal As Long

' Open the key, exit if not found
If RegOpenKeyEx(hKey, KeyName, 0, KEY_WRITE, handle) Then
    Exit Function
End If

' three cases, according to the data type in Value
Select Case VarType(Value)
    Case vbInteger, vbLong
        lngValue = Value
        retVal = RegSetValueEx(handle, ValueName, 0, REG_DWORD, lngValue, 4)
    Case vbString
        strValue = Value
        retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, Len(strValue))
    Case vbArray
        binValue = Value
        length = UBound(binValue) - LBound(binValue) + 1
        retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, binValue(LBound(binValue)), length)
    Case vbByte
        byteValue = Value
        length = 1
        retVal = RegSetValueEx(handle, ValueName, 0, REG_BINARY, byteValue, length)
    Case Else
        RegCloseKey handle
        Err.Raise 1001, , "Unsupported value type"
End Select

RegCloseKey handle  ' Close the key and signal success

SetRegistryValue = (retVal = 0)     ' signal success if the value was written correctly

End Function

Function MergeThePDFs(ByRef strMergeNames() As String, strPath As String, strFInalOutputDoc As String, blnKillIndFiles As Boolean) As Boolean
    Dim acroOrigPdfDoc As Object
    Dim acroNewPdfDoc As Object
    Dim varOrigTotalPages As Long
    Dim varNewTotalPages As Long
    Dim strReportPathName As String
    Dim strDoc2Insert As String
    Dim i As Integer
    Dim varSplit As Variant
    Dim varSplit2 As Variant
    Dim strMergeInputFile As String
    Dim strSQL As String

On Error GoTo Errors

    varSplit = Split(strFInalOutputDoc, "|", , vbTextCompare)
    strMergeInputFile = varSplit(0)

    strReportPathName = strPath

    varSplit = Split(strMergeNames(0), "|", , vbTextCompare)

'    ' delete from the TOC table for the bookmarks
'    strSQL = "DELETE * FROM " & TOC
'    CurrentDb.Execute strSQL, dbFailOnError
   
   
    Set acroOrigPdfDoc = CreateObject("AcroExch.PDDoc")
    Set acroNewPdfDoc = CreateObject("AcroExch.PDDoc")

    'Open the first file.  That is what will be appended to

    '    If acroOrigPdfDoc.Open(varSplit(0)) Then
    If acroOrigPdfDoc.Open(strMergeInputFile) Then
        For i = 0 To UBound(strMergeNames)
            varSplit = Split(strMergeNames(i), "|", , vbTextCompare)
            varOrigTotalPages = acroOrigPdfDoc.GetNumPages

               
            If acroNewPdfDoc.Open(varSplit(0)) Then
                'Get total # of pages to insert
                varNewTotalPages = acroNewPdfDoc.GetNumPages
                'Insert pages into original pdf
                acroOrigPdfDoc.InsertPages varOrigTotalPages - 1, acroNewPdfDoc, 0, _
                                           varNewTotalPages, False

                acroOrigPdfDoc.Save PDSaveCopy, strMergeInputFile
                acroNewPdfDoc.Close
            Else
                MsgBox "Failed to open doc "
            End If
        Next i

        acroOrigPdfDoc.Save PDSaveCopy, strFInalOutputDoc
        acroNewPdfDoc.Close
        '        acroOrigPdfDoc.Close
    End If

    '        MsgBox "Pages added to " & path3
    MergeThePDFs = True

    'Close docs

    If Dir(strPath) <> "" Then
        Kill strPath
    End If

    Set acroOrigPdfDoc = Nothing
    Set acroNewPdfDoc = Nothing
   
    ' rename the report cover file to the actual file name we want
    Name strMergeInputFile As strPath
   
    ' delete individual files if the checkbox was checked on the form
    If blnKillIndFiles Then
        For i = 1 To UBound(strMergeNames)
            varSplit = Split(strMergeNames(i), "|", , vbTextCompare)
            Kill varSplit(0)
        Next i
    End If

ExitHere:
     Exit Function

Errors:
            MergeThePDFs = False
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure MergeThePDFs of Module basAcrobat2", , CurrentDb.Properties("AppTitle")
            Resume ExitHere
            Resume
          
End Function

Function AddBookmarks(strPDFPath As String, blnIncludeCoverTOC As Boolean) As Boolean
    Dim gApp As Object
    Dim gPDDoc As Object
    Dim jso As Object
    Dim BMR As Object
    Dim intWithCover As Integer
    Dim x As Integer
    Dim varBMName As Variant
    Dim varBM As Variant
    Dim rst As DAO.Recordset
    Dim strSQL As String

On Error GoTo Errors
    strSQL = "SELECT tbltmpTableOfContents.ReportCaption, Min(tbltmpTableOfContents.PageNumber) AS Pg " & _
                    "FROM tbltmpTableOfContents " & _
                    "GROUP BY tbltmpTableOfContents.ReportCaption " & _
                    "ORDER BY Min(tbltmpTableOfContents.PageNumber);"
    Set rst = CurrentDb.OpenRecordset(strSQL)
    Set gApp = CreateObject("AcroExch.App")

    Set gPDDoc = CreateObject("AcroExch.PDDoc")
    If gPDDoc.Open(strPDFPath) Then
        Set jso = gPDDoc.GetJSObject

        Set BMR = jso.bookmarkRoot
       
        ' if the cover/toc is included then we add this in and
        ' the integer makes sure the bookmarks are assigned right
        ' further down if the cover/toc are included.
        If blnIncludeCoverTOC Then
            BMR.createchild "Report Cover", "this.pageNum= 0", 0
            BMR.createchild "Table of Contents", "this.pageNum= 1", 1
            intWithCover = intWithCover + 1
        End If
        With rst
            Do Until .EOF
                varBMName = "this.pageNum= " & CStr(!Pg + intWithCover)
                x = !Pg + intWithCover
                varBM = !ReportCaption
                BMR.createchild varBM, varBMName, x
                .MoveNext
            Loop
            gPDDoc.Save PDSaveCopy, strPDFPath

            gPDDoc.Close
        End With
    End If

    Set gPDDoc = Nothing
    rst.Close
    Set rst = Nothing
    AddBookmarks = True

ExitHere:
     Exit Function

Errors:
            AddBookmarks = False
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddBookmarks of Module basAcrobat2", , CurrentDb.Properties("AppTitle")
            Resume ExitHere
            Resume

End Function