Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 sPrinter As String
Dim JobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String
Dim Ar() As String, Cpt As Long, i As Long
sNomPDF = "Essai"
sCheminPDF = ThisWorkbook.Path & "\"
sPrinter = GetPrinterWithPort("PDFCreator")
Set JobPDF = CreateObject("PDFCreator.clsPDFCreator")
JobPDF.cStart "/NoProcessingAtStartup"
With JobPDF
.cPrinterStop = True
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sCheminPDF
.cOption("AutosaveFilename") = sNomPDF
' 0 PDF 1 PNG 2 JPEG 3 BMP 4 PCX 5 TIFF
' 6 PS 7 EPS 8 TXT 9 PDF/A-2B 10 PDF/X 11 PSD
' 12 PCL 13 RAW 14 SVG
.cOption("AutosaveFormat") = 0
.cOption("PDFGeneralAutorotate") = 0
.cClearCache
End With
' Pour n'imprimer que certaines feuilles du classeur
' il faut respecter l'ordre alphabétique des feuilles
Cpt = 0: Erase Ar
For i = 1 To ThisWorkbook.Sheets.Count
If Left$(ThisWorkbook.Sheets(i).Name, 6) = "Feuil1" Or _
Left$(ThisWorkbook.Sheets(i).Name, 6) = "Feuil2" Then
ReDim Preserve Ar(Cpt)
Ar(Cpt) = Sheets(i).Name
Cpt = Cpt + 1
End If
Next i
If Cpt = 0 Then
Set JobPDF = Nothing
Exit Sub
End If
Application.ScreenUpdating = False
Sheets(Ar).Select
Sheets(Ar).PrintOut copies:=1, ActivePrinter:=sPrinter
' Sheets(Array("Feuil1", "Feuil2")).PrintOut copies:=1, ActivePrinter:=sPrinter
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