Create multiple PDF files from Excel

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.

This examples works on both 32 and 64 bit Windows.

Option Explicit

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 -- http://www.biopdf.com/guide/dotnet/chm/html/T_bioPDF_PdfWriter_PdfSettings.htm
    
    Rem -- Create the objects to control the printer settings.
    Rem -- Replace biopdf with bullzip if you have the bullzip printer installed instead
    Rem -- of the biopdf printer.
    Set oPrinterSettings = CreateObject("biopdf.PdfSettings")
    Set oPrinterUtil = CreateObject("biopdf.PdfUtil")
    
    Rem -- Get default printer name
    sPrintername = oPrinterUtil.DefaultPrintername
    oPrinterSettings.Printername = sPrintername
    
    Rem -- Get the full name of the printer
    sFullPrinterName = FindPrinter(sPrintername)
    sFullPrinterName = GetFullNetworkPrinterName(sFullPrinterName)
      
    Rem -- Change to PDF printer
    sCurrentPrinter = ActivePrinter
    ActivePrinter = sFullPrinterName
    
    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

Function GetFullNetworkPrinterName(NetworkPrinterName As String) As String
    Rem -- Returns the full network printer name
    Rem -- Returns an empty string if the printer is not found
    Rem -- E.g. GetFullNetworkPrinterName("HP LaserJet 8100 Series PCL")
    Rem -- Might return "BIOPDF on Ne04:"
    Dim sCurrentPrinterName As String
    Dim sTempPrinterName As String
    Dim i As Long
    
    sCurrentPrinterName = Application.ActivePrinter
    i = 0
    Do While i < 100
        sTempPrinterName = NetworkPrinterName & " on Ne" & Format(i, "00") & ":"
        On Error Resume Next
        Rem -- Try to change to the network printer
        Application.ActivePrinter = sTempPrinterName
        On Error GoTo 0
        If Application.ActivePrinter = sTempPrinterName Then
            Rem -- The network printer was found
            GetFullNetworkPrinterName = sTempPrinterName
            Exit Do
        End If
        i = i + 1
    Loop
    Application.ActivePrinter = sCurrentPrinterName
End Function

Function FindPrinter(sPrinterNameFragment As String) As String
    Rem -- Find the full printer name base on a fragment of the name
    Rem -- Use the GetFullNetworkPrinterName function to get the NeXX
    Rem -- part of the name.
    Dim wsh As Object
    Dim oPrinterCollection
    Dim i As Integer
    
    Set wsh = CreateObject("WScript.Network.1")
    Set oPrinterCollection = wsh.EnumPrinterConnections
    For i = 1 To oPrinterCollection.Count - 1 Step 2
        If InStr(1, LCase(oPrinterCollection(i)), LCase(sPrinterNameFragment)) > 0 Then
            FindPrinter = oPrinterCollection(i)
            Exit Function
        End If
    Next
End Function

Download Example Files

You can download and run the example yourself. The files needed are available here.

Example files (zip archive)