This example shows how you can create multiple PDF documents from a single Microsoft Excel Workbook. The code will run through the sheets in the workbook and create one PDF file per sheet.

The Main-Procedure here inside the coding is PrintSheets()

This examples works on both 32 and 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()
    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 --
        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"
        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
            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
        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
        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
        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
            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)
                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), _
    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

You can download and run the example (Excelfile with Macrocode) yourself. The excel file you needed are available here.


Attachment Size
Example file 63.8 KB