I know you can create a single pdf from multiple reports and set bookmarks by going to the acrobat tab in Access 2010, but is there a way to build a macro that will do this automatically for a large number of reports? Thanks for your help!
pdf maker macro with bookmarks in access 2010
- Thread starter reltub
- Start date
boblarson
Smeghead
- Local time
- Today, 07:34
- Joined
- Jan 12, 2001
- Messages
- 32,059
If using Adobe Acrobat, like we do, you should be able to use this set of code. This contains code which helps in creating PDF's, Merging PDF's, and Creating Bookmarks.
Code:
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
