rebonsoir
Cette nouvelle version permet le suivi d'impression pour plusieurs classeurs consécutifs . Les impressions multi-onglets et les copies multiples sont aussi gérés.
Les informations sur le document en cours d'édition s'affichent dans la barre de statut :
le nombre de pages déja imprimées
le nombre total de pages à imprimer
le nom du document imprimé
Option Explicit
Public NbTotCle As Byte, NbImpCle As Byte, NbImp As Byte
Public FicCle As String
Sub Suivi_Impression_V02()
'michelxld pour le forum http://www.excel-downloads.com
'http://www.excel-downloads.com/html/French/forum/read.php?f=1&i=126077&t=125521
'le 22.11.2004 , testé avec WinXP et Excel2002
'necessite d'activer la reference Microsoft WMI Scripting Library
Dim nomPC As String, Fichier As String
Dim objWMIService As WbemScripting.SWbemServices
Dim colItems As WbemScripting.SWbemObjectSet
Dim objItem As WbemScripting.SWbemObject
Dim objPrintJobSet As Object
Dim NbTot As Byte, i As Byte
Dim Tableau()
nomPC = "."
Set objWMIService = GetObject("winmgmts:\\" & nomPC & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_PrintJob", , 48)
Set objPrintJobSet = objWMIService.InstancesOf("Win32_PrintJob")
ReDim Tableau(objPrintJobSet.Count, 3)
'remarque importante:
'sur mon poste , pour que objItem.PagesPrinted et objItem.TotalPages renvoient des valeurs
'cohérentes j'ai du installer les drivers spécifiques fournis avec l'imprimante
'et les utiliser à la place du driver de WindowsXP par defaut !
For Each objItem In colItems
Tableau(i, 0) = objItem.TotalPages 'nb de pages restant à imprimer
Tableau(i, 1) = objItem.PagesPrinted 'nb de pages imprimées
Tableau(i, 2) = objItem.document 'nom du document en cours d'impression
i = i + 1
Next
Fichier = Tableau(0, 2)
'*************************************************************
'permet de compter les pages pour l'edition de plusieurs onglets d'un document
'ou pour l'impression de plusieurs copies
For i = 0 To UBound(Tableau)
If Tableau(i, 2) = Fichier Then
NbTot = NbTot + Tableau(i, 0)
End If
Next i
If Fichier <> FicCle Then
FicCle = Fichier
NbTotCle = NbTot
NbImp = 0
NbImpCle = 0
Else
If NbImp <> Tableau(0, 1) Then NbImpCle = NbImpCle + 1
NbImp = Tableau(0, 1)
End If
'*************************************************************
Application.StatusBar = "Nombre de pages imprimées : " & NbImpCle & "/" & NbTotCle & " " & Fichier
'***********************************************
If objPrintJobSet.Count = 0 Then
Application.StatusBar = "Impression terminée"
Finir
Exit Sub
End If
'************************************************
Temporisation
End Sub
Sub Temporisation()
Application.OnTime Now + TimeValue("00:00:02"), "Suivi_Impression_V02"
End Sub
Sub Finir()
On Error Resume Next
Application.OnTime Now + TimeValue("00:00:01"), "Suivi_Impression_V02", , Schedule:=False
End Sub
tous vos tests et remarques sont les bienvenus
bonne soirée
MichelXld