Microsoft Access PDF Erzeugung

Dieses Codebeispiel zeigt wie Sie aus einem Access Report programatisch über VBA Macrocode ein PDF erzeugen. Sie erkennen, wie Sie das COM Interface dazu verwenden können um aus einem VBA Programm programatisch einen PDF Druck anzustarten.

Zuerst wird der 7-PDF Printer ermittelt und als Standarddrucker festgelegt, danach erfolgt der Druck des Access Reports in das PDF Format. Dabei werden benutzerdfinierte Einstellungen gesetzt die unter anderem einen Wasserzeichentext in den PDF Report rendern. Danach erfolgt die PDF Ausgabe und der ursprünglich als Standarddrucker definierte Drucker wird wieder als Standard gesetzt.

 

Initiates file downloadCodebeispiel herunterladen

  1. Option Compare Database
  2. Option Explicit
  3.  
  4. Sub PrintReportAsPDF()
  5.     Dim pdf_printer_name As String
  6.     Dim pdf_printer_index As Integer
  7.     Dim current_printer_name As String
  8.     Dim current_printer_index As Integer
  9.     Dim i As Integer
  10.     Dim progid As String
  11.     Dim xmldom As Object
  12.     Dim currentdir As String
  13.     Dim pdfwriter As Object
  14.    
  15.     Rem -- Get the directory of the database
  16.     currentdir = GetDatabaseFolder
  17.    
  18.     Rem -- Read the info xml
  19.     Set xmldom = CreateObject("MSXML.DOMDocument")
  20.     xmldom.Load (currentdir & "\info.xml")
  21.    
  22.     Rem -- Get the program id of the automation object.
  23.     progid = xmldom.SelectSingleNode("/xml/progid").Text
  24.  
  25.     Rem -- Create the printer automation object
  26.     Set pdfwriter = CreateObject(progid)
  27.  
  28.     Rem -- Printer specific settings
  29.     pdf_printer_name = pdfwriter.GetPrinterName
  30.    
  31.     Rem -- Find the index of the printer that we want to use
  32.     pdf_printer_index = -1
  33.     current_printer_index = -1
  34.     current_printer_name = Application.Printer.DeviceName
  35.     For i = 0 To Application.Printers.Count - 1
  36.         If Application.Printers.Item(i).DeviceName = pdf_printer_name Then
  37.             pdf_printer_index = i
  38.         End If
  39.         If Application.Printers.Item(i).DeviceName = current_printer_name Then
  40.             current_printer_index = i
  41.         End If
  42.     Next
  43.    
  44.     Rem -- Exit here if the pdf printer was not found
  45.     If pdf_printer_index = -1 Then
  46.         MsgBox "The printer '" & pdf_printer_name & "' was not found on this computer."
  47.         Exit Sub
  48.     End If
  49.    
  50.     Rem -- Exit here if the current printer was not found
  51.     If current_printer_index = -1 Then
  52.         MsgBox "The current printer '" & current_printer_name & "' was not found on this computer." & _
  53.             " Without this printer the code will not be able to restore the original printer selection."
  54.         Exit Sub
  55.     End If
  56.    
  57.     Rem -- Set the printer
  58.     Application.Printer = Application.Printers(pdf_printer_index)
  59.    
  60.     Rem -- Configure the PDF printer
  61.     With pdfwriter
  62.         Rem -- Set the destination file name of the PDF document
  63.         .SetValue "output", GetDatabaseFolder & "\out\example.pdf"
  64.        
  65.         Rem -- Control the dialogs when printing
  66.         .SetValue "ConfirmOverwrite", "yes"
  67.         .SetValue "ShowSaveAS", "never"
  68.         .SetValue "ShowSettings", "never"
  69.         .SetValue "ShowPDF", "yes"
  70.        
  71.         Rem -- Set document properties
  72.         .SetValue "Target", "printer"
  73.         .SetValue "Title", "Access PDF Example"
  74.         .SetValue "Subject", "Report generated at " & Now
  75.        
  76.         Rem -- Display page thumbs when the document is opened
  77.         .SetValue "UseThumbs", "yes"
  78.        
  79.         Rem -- Set the zoom factor to 50%
  80.         .SetValue "Zoom", "50"
  81.        
  82.         Rem -- Place a stamp in the lower right corner
  83.         .SetValue "WatermarkText", "ACCESS DEMO"
  84.         .SetValue "WatermarkVerticalPosition", "bottom"
  85.         .SetValue "WatermarkHorizontalPosition", "right"
  86.         .SetValue "WatermarkVerticalAdjustment", "3"
  87.         .SetValue "WatermarkHorizontalAdjustment", "1"
  88.         .SetValue "WatermarkRotation", "90"
  89.         .SetValue "WatermarkColor", "#ff0000"
  90.         .SetValue "WatermarkOutlineWidth", "1"
  91.        
  92.         Rem -- Write the settings to the runonce.ini file
  93.         .WriteSettings True
  94.     End With
  95.    
  96.     Rem -- Run the report
  97.     DoCmd.OpenReport "Product Report"
  98. End Sub
  99.  
  100. Function GetDatabaseFolder() As String
  101.     Dim retv As String
  102.     Dim p As Integer
  103.    
  104.     retv = Application.CurrentDb.Name
  105.     p = InStrRev(retv, "\")
  106.     If p > 0 Then
  107.         retv = Left(retv, p)
  108.         If Right(retv, 1) = "\" Then retv = Left(retv, Len(retv) - 1)
  109.     Else
  110.         Err.Raise 1000, , "Unable to determine database folder"
  111.     End If
  112.     GetDatabaseFolder = retv
  113. End Function
  114.