Mehrere PDF Dateien aus einem Excel Dokument erzeugen / PDF Drucker

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