Dieses Beispiel zeigt, wie sie mehrere PDF-Dokumente aus einer einzigen Microsoft Excel-Arbeitsmappe erstellen können. Der Code wird die Arbeitsblätter in der Arbeitsmappe durchlaufen und eine PDF-Datei pro Arbeitsblatt erstellen.

Die Haupt-Prozedur im Code ist PrintSheets()

Dieses Beispiel funktioniert sowohl für 32- als auch für 64-Bit-Windows.

    Option Explicit
    
    Private Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" ( _
        ByVal lpAppName As String, _
        ByVal lpKeyName As String, _
        ByVal lpDefault As String, _
        ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long
    
    Private Const MAX_PRINTERS = 32&
    
    Private strPrinterNames(MAX_PRINTERS) As String
    Private strPrinterDrivers(MAX_PRINTERS) As String
    Private strPrinterPorts(MAX_PRINTERS) As String
    Private intPrinterCount As Integer
    
    Sub PrintSheetsAsPDF()
        PrintSheets
    End Sub
    
    Sub PrintSheets(Optional sFileName As String = "", Optional confirmOverwrite As Boolean = True)
        Dim oPrinterSettings As Object
        Dim oPrinterUtil As Object
        Dim sFolder As String
        Dim sCurrentPrinter As String
        Dim sPrintername As String
        Dim sFullPrinterName As String
        Dim sStatusFileName As String
        
        Rem -- Documentation of the used COM interface is available at the link below.
        Rem -- https://www.7-pdf.com/sites/default/files/guide/dotnet/chm/html/T_pdf7_PdfWriter_PdfSettings.htm
    
        Rem -- Create the objects to control the printer settings.
        Set oPrinterSettings = CreateObject("pdf7.PdfSettings")
        Set oPrinterUtil = CreateObject("pdf7.PdfUtil")
        
        Rem -- Get default printer name
        sPrintername = oPrinterUtil.DefaultPrintername
        oPrinterSettings.Printername = sPrintername
          
        Rem -- Remember variable for current printer selection
        sCurrentPrinter = ActivePrinter
        
        Rem -- Change to default PDF printer name "7-PDF Printer"
        SetToPDFPrinter
        
        Rem -- Set the output folder
        sFolder = Environ("USERPROFILE") & "\Desktop\PDF Example"
        
        Dim sht As Worksheet
        For Each sht In Worksheets
            Rem -- Create a file name for the sheet
            sFileName = sFolder & "\" & sht.Name & ".pdf"
            
            Rem -- Create a file name for the status file
            sStatusFileName = sFolder & "\status-" & sht.Name & ".ini"
            
            Rem -- Remove the status file if it already exists
            If Dir(sStatusFileName) <> "" Then Kill sStatusFileName
        
            Rem -- Write the settings to the printer
            Rem -- Settings are written to the runonce.ini
            Rem -- This file is deleted immediately after being used.
            With oPrinterSettings
                .SetValue "Output", sFileName
                .SetValue "ConfirmOverwrite", "no"
                .SetValue "ShowSettings", "never"
                .SetValue "ShowPDF", "yes"
                .SetValue "StatusFile", sStatusFileName
                .WriteSettings True
            End With
            
            sht.PrintOut
            
            Rem -- Wait for the status file to appear.
            Rem -- This makes sure that we don't overwrite a waiting runonce.ini.
            If Not oPrinterUtil.WaitForFile(sStatusFileName, 10000) Then
                MsgBox "An error occured. No status file was found."
                Exit Sub
            End If
        Next
        
        Rem -- Restore the printer selection
        ActivePrinter = sCurrentPrinter
    End Sub
    
    Public Sub SetToPDFPrinter()
        Dim strBuffer As String
        Dim intIndex  As Integer
        Dim blnFound As Boolean
        strBuffer = Space$(&H2000)
        GetProfileString "PrinterPorts", vbNullString, "", _
            strBuffer, Len(strBuffer)
        GetPrinterNames strBuffer
        GetPrinterPorts
        For intIndex = 0 To intPrinterCount - 1
            If strPrinterNames(intIndex) = "7-PDF Printer" Then
                Application.ActivePrinter = strPrinterNames(intIndex) & " auf " _
                    & strPrinterPorts(intIndex)
                blnFound = True
                Exit For
            End If
        Next
        If Not blnFound Then MsgBox "Printer not found", vbExclamation, "Notice"
    End Sub
    
    Private Sub GetPrinterNames(ByVal strBuffer As String)
        Dim intIndex As Integer
        Dim strName As String
        intPrinterCount = 0
        Do
            intIndex = InStr(strBuffer, Chr(0))
            If intIndex > 0 Then
                strName = Left$(strBuffer, intIndex - 1)
                If Len(Trim$(strName)) > 0 Then
                    strPrinterNames(intPrinterCount) = Trim$(strName)
                    intPrinterCount = intPrinterCount + 1
                End If
                strBuffer = Mid$(strBuffer, intIndex + 1)
            Else
                If Len(Trim$(strBuffer)) > 0 Then
                    strPrinterNames(intPrinterCount) = Trim$(strBuffer)
                    intPrinterCount = intPrinterCount + 1
                End If
                strBuffer = ""
            End If
        Loop While (intIndex > 0) And (intPrinterCount < MAX_PRINTERS)
    End Sub
    
    Private Sub GetPrinterPorts()
        Dim strBuffer As String
        Dim intIndex As Integer
        For intIndex = 0 To intPrinterCount - 1
            strBuffer = Space$(&H400)
            GetProfileString "PrinterPorts", strPrinterNames(intIndex), "", _
                strBuffer, Len(strBuffer)
            GetDriverAndPort strBuffer, strPrinterDrivers(intIndex), _
                strPrinterPorts(intIndex)
        Next
    End Sub
    
    Private Sub GetDriverAndPort(ByVal Buffer As String, _
        DriverName As String, PrinterPort As String)
        Dim intDriver As Integer
        Dim intPort As Integer
        DriverName = ""
        PrinterPort = ""
        intDriver = InStr(Buffer, ",")
        If intDriver > 0 Then
            DriverName = Left$(Buffer, intDriver - 1)
            intPort = InStr(intDriver + 1, Buffer, ",")
            If intPort > 0 Then
                PrinterPort = Mid$(Buffer, intDriver + 1, _
                    intPort - intDriver - 1)
            End If
        End If
    End Sub
    

Sie können das Beispiel (Exceldatei mit fertigem Makro Code) selbst herunterladen und ausführen. Die benötigten Exceldatei sind hier verfügbar.

Downloads

Anhang Größe
Codebeispiel herunterladen 63.8 KB

Top