Automate PDF Creation from Excel Macros
This code example will show you how to automate PDF printing from a Microsoft Excel macro.
You will see how you can locate the correct printer name and use the COM interface to
automate the printer settings. It only shows you the basics, but you can build your own
functionality using this example as an inspiration.
Sub PrintSheetAsPDF()
Dim obj_printer_settings As Object
Dim save_path As String
Dim file_name As String
Dim current_printer As String
Dim xmldom As Object
Dim progid As String
Dim printername As String
Rem -- Read the info xml
Set xmldom = CreateObject("MSXML.DOMDocument")
If Not xmldom.Load(ActiveWorkbook.Path & "\info.xml") Then
MsgBox "Error loading info.xml from """ & ActiveWorkbook.Path & """.", vbCritical
Exit Sub
End If
Rem -- Get the program id of the automation object.
progid = xmldom.SelectSingleNode("/xml/progid").Text
Rem -- Create the object to control the printer settings
Set obj_printer_settings = CreateObject(progid)
Rem -- Get default printer name
printername = obj_printer_settings.GetPrinterName
Rem -- Get the full name of the printer
Dim full_printer_name As String
full_printer_name = FindPrinter(printername)
full_printer_name = GetFullNetworkPrinterName(full_printer_name)
Rem -- Prompt the user for a file name
save_path = Environ("USERPROFILE") & "\Desktop\"
file_name = InputBox("Save PDF to desktop as:", "Sheet '" & _
ActiveSheet.Name & "' to PDF...", ActiveSheet.Name)
Rem -- Abort the process if the user cancels the dialog
If file_name = "" Then Exit Sub
Rem -- Make sure that the file name ends with .pdf
If LCase(Right(file_name, 4)) <> ".pdf" Then
file_name = file_name & ".pdf"
End If
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 obj_printer_settings
.SetValue "output", save_path & file_name
.SetValue "showsettings", "never"
.WriteSettings True
End With
Rem -- Change to PDF printer
current_printer = ActivePrinter
ActivePrinter = full_printer_name
Rem -- Print the active work sheet
ActiveSheet.PrintOut
Rem -- Restore the printer selection
ActivePrinter = current_printer
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 current_printer_name As String
Dim temp_printer_name As String
Dim i As Long
current_printer_name = Application.ActivePrinter
i = 0
Do While i < 100
temp_printer_name = NetworkPrinterName & " on Ne" & _
Format(i, "00") & ":"
On Error Resume Next
Rem -- Try to change to the network printer
Application.ActivePrinter = temp_printer_name
On Error GoTo 0
If Application.ActivePrinter = temp_printer_name Then
Rem -- The network printer was found
GetFullNetworkPrinterName = temp_printer_name
Exit Do
End If
i = i + 1
Loop
Application.ActivePrinter = current_printer_name
End Function
Function FindPrinter(PrinterNameFragment 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 printer
Dim printercoll
Dim i As Integer
Set wsh = CreateObject("WScript.Network.1")
Set printercoll = wsh.EnumPrinterConnections
For i = 1 To printercoll.Count - 1 Step 2
If InStr(1, LCase(printercoll(i)), LCase(PrinterNameFragment)) _
> 0 Then
FindPrinter = printercoll(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)
|
bioPDF