We can programmatically setup print to PDF printer.
Here is the code:
Option Compare Database
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) 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 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
Public Const HKEY_CURRENT_USER As Long = &H80000001
Public Const ERROR_SUCCESS As Long = 0
Public Const KEY_ALL_ACCESS As Long = &H3F
Public Const REG_OPTION_NON_VOLATILE As Long = 0
Public Const REG_SZ As Long = 1
Public Const REG_BINARY As Long = 3
Public Const REG_DWORD As Long = 4
Public Const KEY_READ As Long = &H20019
Public Const KEY_WRITE As Long = &H20006
Public Sub PrintReportToPDF2(ByVal strReport As String, ByVal OutputPath As
String)
'On Error GoTo PrintReportToPDF_error
If (Application.Printers.Count <= 0) Then
MsgBox ("There is no printer drive installed on this computer")
Exit Sub
End If
Dim fso As Scripting.FileSystemObject
Set fso = New FileSystemObject
'-------- Check OutputPath
Dim objArrString() As String
Dim strOutputFile As String
Dim strOutputPath As String
If (InStr(OutputPath, ".") < 0) Then
If Not (Right(OutputPath, 1) = "\") Then
OutputPath = OutputPath & "\"
End If
OutputPath = OutputPath & strReport
End If
objArrString = Split(OutputPath, "\")
If (UBound(objArrString) - LBound(objArrString) > 0) Then
strOutputFile = objArrString(UBound(objArrString))
strOutputPath = Left(OutputPath, Len(OutputPath) - Len(strOutputFile))
Else
MsgBox ("Please specify the output path!")
GoTo PrintReportToPDF_error
End If
If Not (fso.FolderExists(strOutputPath)) Then
fso.CreateFolder (strOutputPath)
End If
If Not (GetFileExtension(strOutputFile) = "pdf") Then
If MsgBox("Output file should be pdf file! Do you wish to change file :
'" & strOutputFile & "' to pdf file?", vbYesNo, "Error") = vbNo Then
GoTo PrintReportToPDF_error
Else
OutputPath = Left(OutputPath, Len(OutputPath) - 3) & "pdf"
End If
End If
If (fso.FileExists(OutputPath)) Then
If MsgBox("File : '" & OutputPath + "' already exist! Do you wish to
overwrite?", vbYesNo, "Error") = vbNo Then
GoTo PrintReportToPDF_error
End If
End If
Const PDF_PRINTER As String = "Adobe PDF" '"GS PDFWriter" '"Adobe PDF"
'Const TEMP_PATH As String = "C:\output.pdf"
Dim prtDefaultPrinter As Printer
'DoCmd.OpenReport strReportName, acViewNormal
'
Dim i As Integer
For i = 0 To Application.Printers.Count - 1
If (Application.Printers.Item(i).DeviceName = PDF_PRINTER) Then
Application.Printer = Application.Printers(PDF_PRINTER)
Exit For
End If
Next
'Create the Registry Key where Acrobat looks for a file name
If Not (CreateNewRegistryKey(HKEY_CURRENT_USER, "Software\Adobe\Acrobat
Distiller\PrinterJobControl")) Then
MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
GoTo PrintReportToPDF_error
End If
'Put the output filename where Acrobat could find it
If Not (SetRegistryValue(HKEY_CURRENT_USER, "Software\Adobe\Acrobat
Distiller\PrinterJobControl", _
Find_Exe_Name(CurrentDb.Name, CurrentDb.Name), OutputPath))
Then
MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description
GoTo PrintReportToPDF_error
End If
'print report
DoCmd.OpenReport strReport, acViewNormal
'-----Close pdf file
Application.Printer = prtDefaultPrinter
'Set fso = New Scripting.FileSystemObject
'fso.CopyFile TEMP_PATH, OutputPath, True
'fso.DeleteFile TEMP_PATH
Set fso = Nothing
Exit Sub
PrintReportToPDF_error:
If Not (prtDefaultPrinter Is Nothing) Then
Application.Printer = prtDefaultPrinter
End If
If Not (fso Is Nothing) Then
Set fso = Nothing
End If
Exit Sub
End Sub
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 Function CreateNewRegistryKey(ByVal prmPredefKey As Long, ByVal
prmNewKey As String) As Boolean
On Error GoTo CreateNewRegistryKey_error
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)
If lRetVal = ERROR_SUCCESS Then
CreateNewRegistryKey = True
Exit Function
Else
CreateNewRegistryKey = False
Exit Function
End If
CreateNewRegistryKey_error:
CreateNewRegistryKey = False
Exit Function
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.
On Error GoTo SetRegistryValue_error
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
SetRegistryValue = False
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
If (retVal = ERROR_SUCCESS) Then ' signal success if the value was written
correctly
SetRegistryValue = True
Exit Function
Else
SetRegistryValue = False
Exit Function
End If
SetRegistryValue_error:
SetRegistryValue = False
Exit Function
End Function
Private Function GetFileExtension(ByVal strFileName As String) As String
Dim objArrFileExt() As String
objArrFileExt = Split(strFileName, ".")
If (UBound(objArrFileExt) - LBound(objArrFileExt) > 0) Then
'' Get the file extension
GetFileExtension = objArrFileExt(UBound(objArrFileExt))
Exit Function
End If
GetFileExtension = ""
End Function
