Advertisement
Guest User

Untitled

a guest
Sep 22nd, 2017
85
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. VBA code that successfully converts an Access report to a PDF file.
  2.  
  3. Instructions:
  4.  
  5. Copy everything below the line into a module in an Access database.
  6.  
  7. To use the code on Access 2000 and earlier, it is necessary to comment out
  8. three lines referring to the printer object and set the report to use PDF995
  9. in the report page layout dialog.
  10.  
  11. The only way to change the printer for a report in these
  12. previous versions is to open the report in design mode and make the change,
  13. re-save the report, and then run it.
  14.  
  15.  
  16.  
  17. To create your pdf file, call the function  
  18. pdfwrite "report name","report filter(may be "")","Path to put the
  19. pdf"
  20.  
  21. A new pdf file named with the name of the report will be created.
  22.  
  23. ------------------------------------------------------
  24. Option Compare Database
  25. Option Explicit
  26.  
  27. 'Read INI settings
  28. Declare Function GetPrivateProfileString Lib "kernel32" Alias _
  29.    "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
  30.    ByVal lpKeyName As Any, ByVal lpDefault As String, _
  31.    ByVal lpReturnedString As String, ByVal nSize As Long, _
  32.    ByVal lpFileName As String) As Long
  33.  
  34. 'Write settings
  35. Declare Function WritePrivateProfileString Lib "kernel32" Alias _
  36.    "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
  37.    ByVal lpKeyName As Any, ByVal lpString As Any, _
  38.    ByVal lpFileName As String) As Long
  39.  
  40. Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  41.  
  42. Public Function FileFolderExists(strFullPath As String) As Boolean
  43. 'Author       : Ken Puls (www.excelguru.ca)
  44. 'Macro Purpose: Check if a folder exists
  45.    On Error GoTo EarlyExit
  46.     If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
  47.    
  48. EarlyExit:
  49.     On Error GoTo 0
  50. End Function
  51.  
  52.  
  53. Sub pdfwrite(reportname As String, destpath As String, Optional strcriteria As String)
  54.  
  55. ' Runs an Access report to PDF995 to create a pdf file from the report.
  56. ' Input parameters are the name of the report within the current database,
  57. ' the path for the output file, and an optional criteria for the report
  58.  
  59. ' Be sure to check that the "Generating PDF CS" setting in pdfsync.ini is set to 0
  60. ' when pdf995 is idle. This codes uses that as a completion flag as it seems to be
  61. ' the most reliable indication that PDF995 is done writing the pdf file.
  62.  
  63.  
  64. ' Note: The application.printer object is not valid in Access 2000
  65. ' and earlier. In that case, set the printer in the report to pdf995
  66. ' and comment out the references herein to the application.printer
  67.  
  68. Dim syncfile As String, maxwaittime As Long
  69. Dim iniFileName As String, tmpPrinter As Printer
  70. Dim outputfile As String, x As Long
  71. Dim tmpoutputfile As String, tmpAutoLaunch As String
  72.  
  73. ' set the location of the PDF995.ini and the pdfsync files
  74. iniFileName = "c:\program files (x86)\pdf995\res\pdf995.ini"
  75. syncfile = "c:\programdata\pdf995\res\pdfsync.ini"
  76.  
  77. ' TEST WHETHER DESTINATION PATH EXISTS - IF NOT ALERT USER AND ABORT PRINT
  78.    If FileFolderExists(destpath) Then
  79.         'MsgBox "Folder exists!"
  80.    Else
  81.         MsgBox "Folder does not exist! Exiting...."
  82.         GoTo Cleanup
  83.     End If
  84.  
  85.  
  86. ' build the output file name from the path parameter and the report name
  87. If Mid(destpath, Len(destpath), 1) <> "\" Then destpath = destpath & "\"
  88. outputfile = destpath & reportname & ".pdf"
  89.  
  90. ' PDF995 operates asynchronously. We need to determine when it is done so we can
  91. ' continue. This is done by creating a file and having PDF995 delete it using the
  92. ' ProcessPDF parameter in its ini file which runs a command when it is complete.
  93.  
  94. ' save current settings from the PDF995.ini file
  95. tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
  96. tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)
  97.  
  98. ' remove previous pdf if it exists
  99. On Error Resume Next
  100. Kill outputfile
  101. On Error GoTo Cleanup
  102.  
  103. ' setup new values in PDF995.ini
  104. x = WritePrivateProfileString("PARAMETERS", "Output File", outputfile, iniFileName)
  105. x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", "0", iniFileName)
  106.  
  107. ' change the default printer to PDF995
  108. ' if running on Access 2000 or earlier, comment out the next two lines
  109. Set tmpPrinter = Application.Printer
  110. Application.Printer = Application.Printers("PDF995")
  111.  
  112. 'print the report
  113. DoCmd.OpenReport reportname, acViewNormal, , strcriteria
  114.  
  115. ' cleanup delay to allow PDF995 to finish up. When flagfile is nolonger present, PDF995 is done.
  116. Sleep (10000)
  117. maxwaittime = 300000 'If pdf995 isn't done in 5 min, quit anyway
  118. Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
  119.     Sleep (10000)
  120.     maxwaittime = maxwaittime - 10000
  121. Loop
  122.  
  123. ' restore the original default printer and the PDF995.ini settings
  124. Cleanup:
  125. Sleep (10000)
  126. x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
  127. x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
  128. x = WritePrivateProfileString("PARAMETERS", "Launch", "", iniFileName)
  129. On Error Resume Next
  130.  
  131. ' if running on Access 2000 or earlier, comment out the next line
  132. Application.Printer = tmpPrinter
  133.  
  134. End Sub
  135.  
  136. Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
  137. Dim x As Long
  138. Dim sDefault As String
  139. Dim sRetBuf As String, iLenBuf As Integer
  140. Dim sValue As String
  141.  
  142. 'Six arguments
  143. 'Explanation of arguments:
  144. 'sSection: ini file section (always between brackets)
  145. 'sEntry : word on left side of "=" sign
  146. 'sDefault$: value returned if function is unsuccessful
  147. 'sRetBuf$ : the value you're looking for will be copied to this buffer string
  148. 'iLenBuf% : Length in characters of the buffer string
  149. 'sFileName: Path to the ini file
  150.  
  151. sDefault$ = ""
  152. sRetBuf$ = String$(256, 0)   '256 null characters
  153. iLenBuf% = Len(sRetBuf$)
  154. x = GetPrivateProfileString(sSection, sEntry, _
  155.            sDefault$, sRetBuf$, iLenBuf%, sFilename)
  156. ReadINIfile = Left$(sRetBuf$, x)
  157.  
  158. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement