Cet exemple montre comment créer plusieurs documents PDF à partir d'un seul classeur Microsoft Excel. Le code parcourt les feuilles de calcul du classeur et crée un fichier PDF par feuille de calcul.

La procédure principale dans le code est PrintSheets()

Cet exemple fonctionne pour Windows 32 et 64 bits.

    Option Explicit
    Private Declare 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
    

Vous pouvez télécharger et exécuter l'exemple vous-même (fichier Excel avec code macro fini). Le fichier Excel requis est disponible ici.

Téléchargements

appendice taille
Télécharger l'exemple de code 63.8 KB

LiveZilla Live Chat Software
Top