The easiest way to Create a PDF file from an Access Report is to use your Windows Registry to manipulate your Default Printer (See sample code after the 5 Steps below):
1) Read in your current default Printer and store it in a variable
2) Change the default printer to the PDF Writer in your Windows Registry
3) Set the value for PDFFileName in the registry so that it will print the Report without having the PDF Creation dialog box from appearing
4) Open the Report so it will print it as a PDF
5) Change the Default Printer from PDF Writer back to the default printer with the variable you used in Step #1
Below is my Subroutine to Print an Access report as a PDF. It takes 3 arguments. 1) The Access Report (sReportName) to convert to PDF 2) The PDF file name you would like to use for the convertd PDF (sPDFFileName) 3) The full path to the new PDF File - this will be stored in the Registry (sFileAttachment):
Public Sub PrintReportToPDF(sReportName As String, sPDFFileName As String, sFileAttachment As String)
Dim sMyDefPrinter As String
' *** PDF Export ***
' Read the current default printer and save the value - we will need this later when we reset the Default Printer
sMyDefPrinter = dhReadRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device")
' Change the default printer to the PDF Writer
If Not dhWriteRegistry(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device", "Acrobat PDFWriter") Then
GoTo Err_RunReport
End If
' Setting the value for PDFFileName in the registry Prints the Report without the dialog box from appearing
If Not dhWriteRegistry(HKEY_CURRENT_USER, "Software\Adobe\Acrobat PDFWriter", "PDFFileName", sFileAttachment) Then
GoTo Err_RunReport
End If
' Open the Report so it will print it
DoCmd.OpenReport sReportName, acViewNormal
' Change the Printer from PDF Writer back to the default printer
dhWriteRegistry HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device", sMyDefPrinter
Exit Sub
Err_RunReport:
' Restore default printer in the Registry
dhWriteRegistry HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device", sMyDefPrinter
MsgBox Err.Description, vbCritical, "Error Creating PDF File"
End Sub
The following functions are required to read/write to the Registry. I put the following code into a separate module named "WindowsRegistry":
Option Compare Database
Option Explicit
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
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" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, _
ByVal ulReserved As Long, ByVal lpClass As String, _
ByVal dwOptions As Long, ByVal samDesired As Long, _
lpSecurityAttributes As Any, 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 dwReserved 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 dwReserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" _
(ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpName As String, lpcbName As Long, _
lpReserved As Long, ByVal lpClass As String, _
lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
(ByVal hKey As Long, ByVal dwIndex As Long, _
ByVal lpValueName As String, lpcbValueName As Long, _
lpReserved As Long, lpType As Long, _
lpData As Any, lpcbData As Any) As Long
' Registry constants
Global Const dhcSuccess = 0
Global Const dhcRegMaxDataSize = 2048
Global Const dhcRegNone = 0
Global Const dhcRegSz = 1
Global Const dhcRegExpandSz = 2
Global Const dhcRegBinary = 3
Global Const dhcRegDWord = 4
Global Const dhcRegDWordLittleEndian = 4
Global Const dhcRegDWordBigEndian = 5
Global Const dhcRegLink = 6
Global Const dhcRegMultiSz = 7
Global Const dhcRegResourceList = 8
Global Const dhcRegFullResourceDescriptor = 9
Global Const dhcRegResourceRequirementsList = 10
Global Const dhcRegOptionReserved = 0
Global Const dhcRegOptionNonVolatile = 0
Global Const dhcRegOptionVolatile = 1
Global Const dhcRegOptionCreateLink = 2
Global Const dhcRegOptionBackupRestore = 4
Global Const dhcReadControl = &H20000
Global Const dhcKeyQueryValue = &H1
Global Const dhcKeySetValue = &H2
Global Const dhcKeyCreateSubKey = &H4
Global Const dhcKeyEnumerateSubKeys = &H8
Global Const dhcKeyNotify = &H10
Global Const dhcKeyCreateLink = &H20
Global Const dhcKeyRead = dhcKeyQueryValue + dhcKeyEnumerateSubKeys + _
dhcKeyNotify + dhcReadControl
Global Const dhcKeyWrite = dhcKeySetValue + dhcKeyCreateSubKey + dhcReadControl
Global Const dhcKeyExecute = dhcKeyRead
Global Const dhcKeyAllAccess = dhcKeyQueryValue + dhcKeySetValue + _
dhcKeyCreateSubKey + dhcKeyEnumerateSubKeys + _
dhcKeyNotify + dhcKeyCreateLink + dhcReadControl
Global Const dhcHKeyClassesRoot = &H80000000
Global Const dhcHKeyCurrentUser = &H80000001
Global Const dhcHKeyLocalMachine = &H80000002
Global Const dhcHKeyUsers = &H80000003
Global Const dhcHKeyPerformanceData = &H80000004
Public Function dhReadRegistry(ByVal lngKeyToGet As Long, sKeyName As String, sKeyValue As String)
Dim hKeyDesktop As Long
Dim lngResult As Long
Dim strBuffer As String
Dim cb As Long
' Open the Requested Key (sKeyName) in the Registry
lngResult = RegOpenKeyEx(lngKeyToGet, sKeyName, 0&, dhcKeyAllAccess, hKeyDesktop)
' Make sure the call succeeded
If lngResult = dhcSuccess Then
' Create the buffer
strBuffer = Space(255)
cb = Len(strBuffer)
' Read the Key value stored in the Registry
lngResult = RegQueryValueEx(hKeyDesktop, sKeyValue, 0&, dhcRegSz, ByVal strBuffer, cb)
' Check return value
If lngResult = dhcSuccess Then
' Return the current value
dhReadRegistry = Left(strBuffer, cb - 1)
End If
' Close the Registry Key
lngResult = RegCloseKey(hKeyDesktop)
End If
End Function
Public Function dhWriteRegistry(ByVal lngKeyToGet As Long, sKeyName As String, sKeyValue As String, sNewValue As String) As Boolean
Dim hKeyDesktop As Long
Dim lngResult As Long
' Open the Requested Key (sKeyName) in the Registry
lngResult = RegOpenKeyEx(lngKeyToGet, sKeyName, 0&, dhcKeyAllAccess, hKeyDesktop)
' Make sure the call succeeded
If lngResult = dhcSuccess Then
' Save the value to the Registry
lngResult = RegSetValueEx(hKeyDesktop, sKeyValue, 0&, dhcRegSz, ByVal sNewValue, Len(sNewValue))
' Check return value
If lngResult = dhcSuccess Then
' Success
dhWriteRegistry = True
Else
' Failure
dhWriteRegistry = False
End If
' Close the Registry Key
lngResult = RegCloseKey(hKeyDesktop)
End If
End Function
