'API pour déterminer l'imprimante par défaut.
Dans le haut du module standard
'---------------------------------------------------------------------------------
Private Const ERROR_INSUFFICIENT_BUFFER = 122&
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias _
"GetDefaultPrinterA" (ByVal pszBuffer As String, _
ByRef pcchBuffer As Long) As Long
'---------------------------------------------------------------------------------
Sub test()
Dim Wd As Object, Dc As Object
Dim Chemin As String, Fichier As String
Dim NouveauNom As String, ImprimanteActuel As String
'Répertoire où est le document
Chemin = "c:\Users\Ton Profil\Documents\"
'Nom du document Word
Fichier = "Test.docm"
'Nouveau nom qu'aura le ficher pdf (test.pdf)
NouveauNom = Left(Fichier, Len(Fichier) - _
VBA.InStrRev(Fichier, ".")) & ".pdf"
Application.ScreenUpdating = False
'Création d'un instance Word
Set Wd = CreateObject("Word.Application")
'Désactive l'exécution des macros à l'ouverture du fichier
Wd.AutomationSecurity = msoAutomationSecurityForceDisable
'Ouverture du fichier Word
Set Dc = Wd.documents.Open(Chemin & Fichier)
'Définir l'imprimante active afin de pouvoir la
'remettre à la fin de l'opération
ImprimanteActuel = Nom_Imprimante_Active
'Lancer la procédure devant créer le fichier PDF
Call Instancier_PdFCreator(Dc, Chemin, NouveauNom)
'Remettre par défaut l'imprimante du début
Call Définir_Imprimante_Par_défaut(ImprimanteActuel)
Dc.Close False
Wd.Quit
'Libère la mémoire des objets
Set Dc = Nothing: Set Wd = Nothing
Application.ScreenUpdating = True
End Sub
'-------------------------------------------------------------------------------
Sub Instancier_PdFCreator(Dc As Object, Répertoire As String, _
FichierDest As String)
killtask ("PDFCreator.exe") 'Procédure écrite plus bas...
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
'Make sure the PDF printer can start
If pdfjob.cStart("/NoProcessingAtStartup") = False Then
MsgBox "Imposssible d'initialiser PDFCreator.", vbCritical + _
vbOKOnly, "Erreur!"
Exit Sub
End If
'Set all defaults
With pdfjob
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = Répertoire
.cOption("AutosaveFilename") = FichierDest
.cOption("AutosaveFormat") = 0
.cClearCache
.cPrinterStop = True
End With
Dc.PrintOut copies:=1, ActivePrinter:="PDFCreator"
With pdfjob
.cPrinterStop = True
.cCombineAll
DoEvents
.cPrinterStop = False
End With
'Wait until PDF creator is finished then release the objects
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
pdfjob.cClose
End Sub
'---------------------------------------------------------------------------------
Sub killtask(sappname As String)
Dim oProclist As Object
Dim oWMI As Object
Dim oProc As Object
Set oWMI = GetObject("winmgmts:")
If IsNull(oWMI) = False Then
Set oProclist = oWMI.InstancesOf("win32_process")
For Each oProc In oProclist
If UCase(oProc.Name) = UCase(sappname) Then
oProc.Terminate (0)
End If
Next oProc
Else
MsgBox "Killing """ & sappname & _
""" - Can't create WMI Object.", _
vbOKOnly + vbCritical, "CloseAPP_B"
End If
Set oProclist = Nothing
Set oWMI = Nothing
End Sub
'---------------------------------------------------------------------------------
Sub Définir_Imprimante_Par_défaut(NomImprimante As String)
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colInstalledPrinters = objWMIService.ExecQuery _
("Select * from Win32_Printer Where Name = '" & NomImprimante & "'")
For Each objPrinter In colInstalledPrinters
objPrinter.SetDefaultPrinter
Next
End Sub
'---------------------------------------------------------------------------------
Function Nom_Imprimante_Active()
Dim lResult As Long, BufLen As Long
Dim PrinterName As String
BufLen = 0
' Récupère la taille nécessaire pour le nom
lResult = GetDefaultPrinter(PrinterName, BufLen)
' Alloue le buffer pour le nom
PrinterName = String(BufLen, 0)
lResult = GetDefaultPrinter(PrinterName, BufLen)
' Supprime le zéro binaire de fin
Nom_Imprimante_Active = Left(PrinterName, InStr(PrinterName, Chr$(0)) - 1)
End Function
'---------------------------------------------------------------------------------
