Sauvegarde au format pdf par défaut

Option Explicit

Private Function GetPrinterWithPort(ByVal sPrinterName As String) As String
Dim Reg As Variant, oReg As Object, Str As Variant
Dim Ar() As Variant, RegValue As Variant
Const HKEY_CURRENT_USER = &H80000001
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    With oReg
        .enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Str, Ar
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Reg, RegValue
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", sPrinterName, RegValue
    End With
    GetPrinterWithPort = sPrinterName & " sur " & Mid$(RegValue, InStr(RegValue, ",") + 1)
End Function

Sub Tst_PDF()
Dim sPrinter As String, sPDFPrinter As String
    sPrinter = Application.ActivePrinter

    sPDFPrinter = GetPrinterWithPort("PDFCreator")
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:=sPDFPrinter, Collate:=True
    
    Application.ActivePrinter = sPrinter
End Sub

Option Explicit

Private Function GetPrinterWithPort(ByVal sPrinterName As String) As String
Dim Reg As Variant, oReg As Object, Str As Variant
Dim Ar() As Variant, RegValue As Variant
Const HKEY_CURRENT_USER = &H80000001
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    With oReg
        .enumvalues HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Str, Ar
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", Reg, RegValue
        .getstringvalue HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Devices", sPrinterName, RegValue
    End With
    GetPrinterWithPort = sPrinterName & " sur " & Mid$(RegValue, InStr(RegValue, ",") + 1)
End Function

Sub TstPdfCreator()
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim Ar() As String, i As Long
Dim sPrinter As String

    sNomPDF = "Essai"
    sCheminPDF = ThisWorkbook.Path & "\"
    sPrinter = GetPrinterWithPort("PDFCreator")

    Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
    JobPDF.cStart "/NoProcessingAtStartup"

    With JobPDF
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sCheminPDF
        .cOption("AutosaveFilename") = sNomPDF
        .cOption("AutosaveFormat") = 0    ' PDF
        .cOption("PDFGeneralAutorotate") = 0
        .cClearCache
    End With

    For i = 1 To ThisWorkbook.Sheets.Count
        ReDim Preserve Ar(i - 1)
        Ar(i - 1) = Sheets(i).Name
    Next i
    
    Application.ScreenUpdating = False

    Sheets(Ar).Select
    Sheets(Ar).PrintOut copies:=1, ActivePrinter:=sPrinter

    ' Resélectionner une feuille seulement
    Worksheets(1).Select
    Erase Ar
    Application.ScreenUpdating = True
    DoEvents

    '   Fichier dans la file d'attente
    Do Until JobPDF.cCountOfPrintjobs = 1
        DoEvents
    Loop
    '   Démarrage Imprimante
    JobPDF.cPrinterStop = False

    '   Attendre que la file d'attente soit vide
    Do Until JobPDF.cCountOfPrintjobs = 0
        DoEvents
    Loop

    JobPDF.cClose
    Set JobPDF = Nothing
End Sub