How do I print this MS Access Report as a PDF (I have code!!!) 1

[Robmaag]

I have an access application that I downloaded that has some nice code for having MS Access Reports being automatically printed as PDFs. The code works fine but I have a report that I tried to print as a pdf but it doesn't go anywhere and it doesn't automatically bring up adobe. The report in question is called 'Employees Reports'. I have attached the database along with the 2 .dll files in question.

What I need is the ability of this Employees Report (it contains images) to be able to be printed as a pdf.

I can print other MS Access Reports as PDFs but I am not able to print this one as you can see when you open the form in the attached database 'HowToUse'.

It appears that the problem is that when the Employees Report in MSAccess is converted to a SNP file extension, it doesn't open up the adobe application to show the report. I believe the real problem is in the Employees Report itself. There is some VBA code in the detail section of the Report that I think is causing this Access Report to PDF to not work.

Here is the code that is preventing this report to be converted to a pdf...

Me.PhotoImage2.Picture = Me.FileList2

This line is embedded in the following code:

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Dim PhotoImage2 As String
Dim FileList2 As String

'DoCmd.OpenReport stDocName, acNormal

If IsNull(Me.PhotoImage2.Picture) Then
DoCmd.SetWarnings False
Else
Me.PhotoImage2.Picture = Me.FileList2
End If

End Sub

Objective: To somehow get the Employees Report to print as a pdf. I believe with the code in the details section is it preventing this from happening but the problem is if I remark it out, it the Employees Report will print to a PDF but I will lose the associated image.

 

[T111]

Hi Rob,
I have and application in Access that works fine converting an access report to PDF and then emailing the report. Forgot where I got the code but its as follows

Dim EmailAddress As String
If Me.cboEmail <> "" Then
EmailAddress = GetEmailAddress(Me.cboEmail)
Else
EmailAddress = ""
End If

Dim FullFileName As String
FullFileName = MainDirectory & "\PDFs\Invoice\" & Me.InvoiceNo & ".pdf"

Dim EmailSignature As String
EmailSignature = Me.cboEmployee

Dim R As Boolean
R = RunReportAsPDF("rptInvoiceQuick", FullFileName, "w:\")
If Not R Then
MsgBox "PDF File was not created!", vbCritical, "Warning!"
Else
EmailNotificationMessages "INV", EmailAddress, "Invoice No : " & Me.InvoiceNo, EmailSignature, FullFileName
End If



'Create a new Module
Public dbName As String
Public MainDirectory As String

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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_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))

Public Function RunReportAsPDF(sAccessRptName As String, sPDFName As String, sOutputFolder As String) As Boolean

' Returns TRUE if a PDF file has been created
Dim AdobeDevice As String
Dim sDefaultPrinter As String, sPDFPrinterFolder As String
Dim sDefault As String

' Find the Acrobat PDF device
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 Adobe Acrobat before using this feature", vbCritical, "Adobe Acrobat Not Installed"
RunReportAsPDF = False
Exit Function
End If

' Access 2000
' Read the current default printer and save the value
sDefaultPrinter = GetRegistryValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device")
' Store the Default folder for the PDF Printer where it prints the PDF files to
sPDFPrinterFolder = GetRegistryValue(HKEY_CURRENT_USER, "Software\ADOBE\Acrobat Distiller\7.0\AdobePDFOutputFolder", "2")
' Read the "Default" value from the registry first, to determine which item to read.
sDefault = GetRegistryValue(HKEY_CURRENT_USER, "Software\ADOBE\Acrobat Distiller\7.0\AdobePDFOutputFolder", "(Default)")
sPDFPrinterFolder = "W:\"
' Change the default printer to Adobe PDF
If Not SetRegistryValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device", "Adobe PDF") Then
GoTo Err_handler
End If

' Change the Folder where the PDF file will get Saved to. This is set in the
' AdobePDFOutputFolder key in the Registry
'If Not SetRegistryValue(HKEY_CURRENT_USER, "Software\ADOBE\Acrobat Distiller\7.0\AdobePDFOutputFolder", sDefault, sOutputFolder) Then
' GoTo Err_handler
'End If

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

' Put the output filename where Acrobat could find it
SetRegistryValue HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl", _
Find_Exe_Name(dbName, dbName), _
sPDFName

On Error GoTo Err_handler

DisplayReportPrint (sAccessRptName)

' Wait for the PDF to actually get Created.
'While Len(Dir(sOutputFolder & "\" & sPDFName)) = 0
' DoEvents
'Wend

' File Created - Success
RunReportAsPDF = True

Normal_Exit:
' Restore default printer settings
SetRegistryValue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", "Device", sDefaultPrinter
SetRegistryValue HKEY_CURRENT_USER, "Software\ADOBE\Acrobat Distiller\7.0\AdobePDFOutputFolder", "2", sPDFPrinterFolder



On Error GoTo 0

Exit Function

Err_handler:
If Err.Number = 2501 Then ' The report did not run properly (ex NO DATA)
RunReportAsPDF = False
Resume Normal_Exit
Else
RunReportAsPDF = False ' The report did not run properly (anything else!)
MsgBox "Unexpected error #" & Err.Number & " - " & Err.Description, vbCritical, "Error Running Report"
Resume Normal_Exit
End If

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, hKey)

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

 

[tiagows]

Robmaag,

The problem is due to the path of the photos. They are stored at field 'Photo' in the table 'Employees'. So if tou put there a valid path for each row it will work. You must put a valid path for all the 66 rows.

Try to run a SQL statement like this:

UPDATE Employees SET Employees.Photo = "f:\2.jpg";

just change the f:\2.jpg for a valid path of an image on your computer. I tested here and it works fine.


T111,

thanks for your post, I'm studying it. It's very interesting!

 

[Sux2Lose]

T111,

Any chance you can help me implement your code? I'm an intermediate vba user so its a little over my head. I am getting a couple errors.

Thanks.

 

[karlf]

I'm getting an error on

DisplayReportPrint (sAccessRptName)

it tells me that the sub or function is not defined.

Help

Thanks,

Karl