'-----------------------------------------------------------------------------------------
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 Word.Application, Dc As Word.document
Dim Chemin As String, Fichier As String
Dim NouveauNom As String, ImprimanteActuel As String
'Répertoire où est le document
Chemin = "c:\Users\MichD\Documents\"
'Nom du document Word
Fichier = "Martine aime martine.docm"
'Vérifie que le fichier existe vraiment dans le répertoire indiqué.
If Dir(Chemin & fichier) = "" Then
MsgBox "Le fichier """ & fichier & """ indiqué n'existe " & _
"pas dans ce répertoire " & Chemin & """ . Vérifier. Procédure annulée.", _
vbCritical + vbOKOnly, "Attention"
Exit Sub
End If
'Nouveau nom qu'aura le ficher pdf (test.pdf)
NouveauNom = Left(Fichier, VBA.InStrRev(Fichier, ".") - 1) & ".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
'Définir l'imprimante de l'application Word
Wd.ActivePrinter = "PdfCreator"
'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 Word.document, 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 ' 0 = PDF
.cClearCache
.cPrinterStop = True
End With
Dc.PrintOut copies:=1
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False
'Wait until the file shows up before closing PDF Creator
Do
DoEvents
Loop Until Dir(Répertoire & FichierDest) = FichierDest
pdfjob.cClose
Set pdfjob = Nothing
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
'-----------------------------------------------------------------------------------------
