Microsoft Access PDF Erzeugung / PDF Drucker

Option Compare Database
Option Explicit

Public Function GetUniqueJobId() As String
    Rem -- I know this is not bullit proof but good enough for the example
    GetUniqueJobId = Timer
End Function

Public Function PrintReportAsPDF()
    Const REPORT_NAME = "Product Report"
    
    Dim pdf_printer_name As String
    Dim pdf_printer_index As Integer
    Dim current_printer_name As String
    Dim current_printer_index As Integer
    Dim i As Integer
    Dim progid As String
    Dim xmldom As Object
    Dim pdfSettings As Object
    Dim pdfUtil As Object
    Dim jobid As String
    Dim rpt As Report
    Dim printjob_name As String
    Dim fn As String
    
    DoEvents
    
    Rem -- Create the printer automation object
    Set pdfSettings = CreateObject("pdf7.PdfSettings")
    Set pdfUtil = CreateObject("pdf7.PdfUtil")

    Rem -- Printer specific settings
    pdf_printer_name = pdfUtil.DefaultPrinterName
    
    Rem -- Find the index of the printer that we want to use
    pdf_printer_index = -1
    current_printer_index = -1
    current_printer_name = Application.Printer.DeviceName
    For i = 0 To Application.Printers.Count - 1
        If Application.Printers.Item(i).DeviceName = pdf_printer_name Then
            pdf_printer_index = i
        End If
        If Application.Printers.Item(i).DeviceName = current_printer_name Then
            current_printer_index = i
        End If
    Next
    
    Rem -- Exit here if the pdf printer was not found
    If pdf_printer_index = -1 Then
        MsgBox "The printer '" & pdf_printer_name & "' was not found on this computer."
        Exit Function
    End If
    
    Rem -- Exit here if the current printer was not found
    If current_printer_index = -1 Then
        MsgBox "The current printer '" & current_printer_name & "' was not found on this computer." & _
            " Without this printer the code will not be able to restore the original printer selection."
        Exit Function
    End If
    
    Rem -- Create a job id for the print job to make a runonce file that will only match this print job.
    Rem -- This will handle the situation where multiple processes running in the same user context produces print jobs.
    Rem -- It will make sure that the settings are used for the correct print job.
    jobid = GetUniqueJobId
    printjob_name = REPORT_NAME & " " & jobid
    
    Rem -- Set the printer
    Application.Printer = Application.Printers(pdf_printer_index)
    
    Rem -- Configure the PDF printer
    With pdfSettings
        .PrinterName = pdf_printer_name
        
        Rem -- Set the destination file name of the PDF document
        .SetValue "output", GetDatabaseFolder & "\out\example.pdf"
        
        Rem -- Control the dialogs when printing
        .SetValue "ConfirmOverwrite", "no"
        .SetValue "ShowSaveAS", "never"
        .SetValue "ShowSettings", "never"
        .SetValue "ShowPDF", "yes"
        
        Rem -- Set document properties
        .SetValue "Target", "printer"
        .SetValue "Title", "Access PDF Example"
        .SetValue "Subject", "Report generated at " & Now
        
        Rem -- Display page thumbs when the document is opened
        .SetValue "UseThumbs", "yes"
        
        Rem -- Set the zoom factor to 50%
        .SetValue "Zoom", "50"
        
        Rem -- Place a stamp in the lower right corner
        .SetValue "WatermarkText", "ACCESS DEMO"
        .SetValue "WatermarkVerticalPosition", "bottom"
        .SetValue "WatermarkHorizontalPosition", "right"
        .SetValue "WatermarkVerticalAdjustment", "3"
        .SetValue "WatermarkHorizontalAdjustment", "1"
        .SetValue "WatermarkRotation", "90"
        .SetValue "WatermarkColor", "#ff0000"
        .SetValue "WatermarkOutlineWidth", "1"
        .SetValue "KeyWords", jobid
        
        Rem -- Write the settings to the runonce_jobid.ini file
        Rem -- First we get the full path of the runonce matching the name of our print job
        fn = .GetSettingsFilePathEx2("runonce", printjob_name)
        Rem -- Then we save the settings to that file name
        .WriteSettingsFile fn
    End With
    
    Rem -- Run the report
    DoCmd.OpenReport REPORT_NAME, View:=acViewPreview, WindowMode:=acHidden
    Set rpt = Reports(REPORT_NAME)
    Set rpt.Printer = Application.Printers(pdf_printer_name)
    rpt.Caption = printjob_name
    DoCmd.OpenReport REPORT_NAME
    DoCmd.Close acReport, REPORT_NAME
    
    Rem -- Alternative strategy to control the name of the print job
    Rem -- This solution is to copy the report to a temp report object with a different name
    'DoCmd.OpenReport REPORT_NAME
    'DoCmd.CopyObject , printjob_name, acReport, REPORT_NAME
    'DoCmd.OpenReport printjob_name
    'DoCmd.DeleteObject acReport, printjob_name
End Function

Function GetDatabaseFolder() As String
    Dim retv As String
    Dim p As Integer
    
    retv = Application.CurrentDb.Name
    p = InStrRev(retv, "\")
    If p > 0 Then
        retv = Left(retv, p)
        If Right(retv, 1) = "\" Then retv = Left(retv, Len(retv) - 1)
    Else
        Err.Raise 1000, , "Unable to determine database folder"
    End If
    GetDatabaseFolder = retv
End Function