Générez plusieurs fichiers PDF à partir d'un document Excel / Imprimante PDF

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