Soyez le premier à donner votre avis sur cette source.
Vue 10 025 fois - Téléchargée 960 fois
' Pour copier une zone de mémoire Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) ' Pour récupérer le nom d'utilisateur en connaissant son ID Public Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As Long, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long Public Const ERROR_INSUFFICIENT_BUFFER = 122& ' Pour faire la liste des processus Public Type WTS_PROCESS_INFO SessionID As Long ' Identificateur de la session ProcessID As Long ' Identificateur du processus pProcessName As Long ' Pointeur vers le nom du processus pUserSid As Long ' Pointeur vers l'ID de l'utilisateur associé au processus End Type ' Fait la liste des processus en mémoire à l'endroit désigné par le pointeur : pProcessInfo ' Count est le nombre de processus Public Declare Function WTSEnumerateProcesses Lib "wtsapi32.dll" Alias "WTSEnumerateProcessesA" (ByVal hServer As Long, ByVal Reserved As Long, ByVal Version As Long, ByRef pProcessInfo As Long, ByRef Count As Long) As Long ' Libère la mémoire utilisée par la liste des processus crée avec la fonction d'au dessus Public Declare Sub WTSFreeMemory Lib "wtsapi32.dll" (ByVal pMemory As Long) Public Const WTS_CURRENT_SERVER_HANDLE = 0& ' Permet de récupérer la liste des processus avec leurs infos ' tabProcessInfo() : de 0 à Count-1 Public Function mpListProcessInfo(tabProcessInfo() As WTS_PROCESS_INFO, Count As Long) As Long Dim RetVal As Long Dim i As Integer Dim pBuffer As Long, Pointeur As Long ReDim tabProcessInfo(0) As WTS_PROCESS_INFO ' Fait la liste des processus en mémoire dans un buffer à l'endroit désigné par le pointeur : pBuffer RetVal = WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0&, 1, pBuffer, Count) Pointeur = pBuffer ' Si ça a fonctionné If RetVal Then For i = 0 To Count - 1 ' Sauvegarde dans le tableau ReDim Preserve tabProcessInfo(i) As WTS_PROCESS_INFO ' La liste des processus est en mémoire : on la copie de la mémoire dans notre variable CopyMemory tabProcessInfo(i), ByVal Pointeur, LenB(tabProcessInfo(i)) ' On calcule la position de la prochaine structure d'info sur les process en mémoire Pointeur = Pointeur + LenB(tabProcessInfo(i)) Next i ' Libère le buffer de la mémoire WTSFreeMemory pBuffer ' La fonction a réussi mpListProcessInfo = 1 Else ' Il y a eu une erreur dans WTSEnumerateProcesses mpListProcessInfo = Err.LastDllError End If End Function ' Permet de récupérer le nom d'utilisateur associé à un processus Public Function mpGetUserNameFromProcess(ProcessID As Long) As String Dim RetVal As Long Dim Count As Long, i As Long Dim pBuffer As Long, Pointeur As Long Dim ProcessInfo As WTS_PROCESS_INFO mpGetUserNameFromProcess = "" ' Fait la liste des processus en mémoire dans un buffer à l'endroit désigné par le pointeur : pBuffer RetVal = WTSEnumerateProcesses(WTS_CURRENT_SERVER_HANDLE, 0&, 1, pBuffer, Count) Pointeur = pBuffer ' Si ça a fonctionné If RetVal Then ' On les parcours tous For i = 0 To Count - 1 ' La liste des processus est en mémoire : on la copie de la mémoire dans notre variable CopyMemory ProcessInfo, ByVal Pointeur, LenB(ProcessInfo) ' Si c'est le notre, on récupère le nom d'utilisateur If ProcessInfo.ProcessID = ProcessID Then mpGetUserNameFromProcess = mpGetUserNameFromUserID(ProcessInfo.pUserSid) ' On sort de la boucle Exit For End If ' On calcule la position de la prochaine structure d'info sur les process en mémoire Pointeur = Pointeur + LenB(ProcessInfo) Next i ' Libère le buffer de la mémoire WTSFreeMemory pBuffer End If End Function ' Renvoie le nom d'utilisateur correspondant à son identificateur Public Function mpGetUserNameFromUserID(ByVal UserID As Long) As String Dim bSuccess As Long ' La variable de retour des fonctions Dim name As String ' Nom de l'utilisateur Dim domain_name As String ' Nom du domaine pour l'utilisateur Dim name_len As Long ' Longueur de la chaine "name" (à initialiser) Dim domain_len As Long ' Longueur de la chaine "domain_name" (à initialiser) Dim deUse As Long ' Pointeur vers un type SID_NAME_USE qui indique le type du compte name = "" domain_name = "" name_len = 0 domain_len = 0 ' On appelle une première fois pour récupérer la taille des variables name et domain_name bSuccess = LookupAccountSid(vbNullString, UserID, name, name_len, domain_name, domain_len, deUse) If (bSuccess = 0) And (Err.LastDllError <> ERROR_INSUFFICIENT_BUFFER) Then mpGetUserNameFromUserID = "" Exit Function End If ' Dimensionne name = Space(name_len - 1) domain_name = Space(domain_len - 1) ' Récupère le nom d'utilisateur bSuccess = LookupAccountSid(vbNullString, UserID, name, name_len, domain_name, domain_len, deUse) mpGetUserNameFromUserID = name End Function
15 juil. 2006 à 12:48
Joli code MadM@tt, perso je conseillerais plutot d'utiliser ta methode que WMi, pas tant pour les performances, mais parceque Wmi peut etre desactiver sur la machine et dans ce cas ca ne marchera pas...
Bonne prog a tous
++
15 juil. 2006 à 01:14
Merci en tout cas pour ces supers infos et méthodes
15 juil. 2006 à 01:09
je viens de tester sur mon PC qui a déjà un sacré coup dans l'aile : environ 3 secondes en passant pas une string (affichée à la fin).
et pour les infos principales...., quasi instantané :
Dim sBuffer As String
sBuffer = "===================================================="
Text1.FontName "Courier New": Text1.FontSize 8
On Local Error GoTo Err_Handler
Dim objWMIService As Object, WMI_ObjProps As Object, ObjClsItem As Object
' on ouvre le service
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}" & _
"!\" & Environ$("COMPUTERNAME") & "\root\cimv2")
' recherche
Set WMI_ObjProps = objWMIService.ExecQuery("Select * from Win32_Process", , 48)
' lecture
For Each ObjClsItem In WMI_ObjProps
sBuffer = sBuffer & vbCrLf & "Caption: " & ObjClsItem.Caption
sBuffer = sBuffer & vbCrLf & "S_Id: " & ObjClsItem.SessionId & "P_Id: " & ObjClsItem.ProcessId
sBuffer = sBuffer & vbCrLf & "WorkingSetSize: " & ObjClsItem.WorkingSetSize \ 1024 & "Ko"
sBuffer = sBuffer & vbCrLf & "====================================================" & vbCrLf
Next
Text1.Text = sBuffer
15 juil. 2006 à 00:46
ouin pourquoi moaaaaa....
Par contre c'est super lent comme méthode non ??? Enfin chez moi (pc pas mal rapide) j'ai bien attendu une 10aine de seconde.
Enfin je t'explique, à la base j'avais besoin absolument de ce code pour récupérer la conso CPU de chaque processus. J'y suis enfin arrivé, et en fait je viens de réaliser que je n'ai pas besoin du tout de ce code en fait, donc tout ce boulot pour rien. Et de toute façon vu comment la méthode que tu propose est lente, je n'aurais pas pu l'utiliser non plus (et oui conso CPU en temps réel, pour chaque process, ça risque d'etre difficile d'attendre 10s entre chaque refresh lol).
Enfin merci beaucoup pour m'avoir apporté ce petit bout de connaissance, mais je suis vraiment désolé,mais je ne m'ouvrirai pas les veines ce soir... je viens juste de réussir à obtenir cette ***** de conso CPU, depuis des année que je la voulai, pas un code sur vbfrance, pas un post dans le forum.... le néant
Pfff enfin c'est le bonheur dans ma chambre la, wouhou !
15 juil. 2006 à 00:15
apparemment il faut ensuite aller lire Win32_ComputerSystem (avec les ID récupérés...)
bon en attendant, place une txtbox sur une form, multilignes avec bothscroll, puis copie ce code, F5, et enfin sort ton cutter :p
Private Sub Form_Load()
'Me.AutoRedraw = True
Text1.Text = ""
Text1.FontName = "Courier New"
Text1.FontSize = 8
On Local Error GoTo Err_Handler
Dim objWMIService As Object, WMI_ObjProps As Object, ObjClsItem As Object
' on ouvre le service
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}" & _
"!\" & Environ$("COMPUTERNAME") & "\root\cimv2")
' recherche
Set WMI_ObjProps = objWMIService.ExecQuery("Select * from Win32_Process", , 48)
' lecture
For Each ObjClsItem In WMI_ObjProps
'Me.Print ObjClsItem.SessionId & vbTab & "[" & ObjClsItem.ProcessId & "]" & vbTab & vbTab & ObjClsItem.Name
Text1.Text = Text1.Text & "===================================================="
Text1.Text = Text1.Text & vbCrLf & "Caption: " & ObjClsItem.Caption
Text1.Text = Text1.Text & vbCrLf & "CommandLine: " & ObjClsItem.CommandLine
Text1.Text = Text1.Text & vbCrLf & "CreationClassName: " & ObjClsItem.CreationClassName
Text1.Text = Text1.Text & vbCrLf & "CreationDate: " & ObjClsItem.CreationDate
Text1.Text = Text1.Text & vbCrLf & "CSCreationClassName: " & ObjClsItem.CSCreationClassName
Text1.Text = Text1.Text & vbCrLf & "CSName: " & ObjClsItem.CSName
Text1.Text = Text1.Text & vbCrLf & "Description: " & ObjClsItem.Description
Text1.Text = Text1.Text & vbCrLf & "ExecutablePath: " & ObjClsItem.ExecutablePath
Text1.Text = Text1.Text & vbCrLf & "ExecutionState: " & ObjClsItem.ExecutionState
Text1.Text = Text1.Text & vbCrLf & "Handle: " & ObjClsItem.Handle
Text1.Text = Text1.Text & vbCrLf & "HandleCount: " & ObjClsItem.HandleCount
Text1.Text = Text1.Text & vbCrLf & "InstallDate: " & ObjClsItem.InstallDate
Text1.Text = Text1.Text & vbCrLf & "KernelModeTime: " & ObjClsItem.KernelModeTime
Text1.Text = Text1.Text & vbCrLf & "MaximumWorkingSetSize: " & ObjClsItem.MaximumWorkingSetSize
Text1.Text = Text1.Text & vbCrLf & "MinimumWorkingSetSize: " & ObjClsItem.MinimumWorkingSetSize
Text1.Text = Text1.Text & vbCrLf & "Name: " & ObjClsItem.Name
Text1.Text = Text1.Text & vbCrLf & "OSCreationClassName: " & ObjClsItem.OSCreationClassName
Text1.Text = Text1.Text & vbCrLf & "OSName: " & ObjClsItem.OSName
Text1.Text = Text1.Text & vbCrLf & "OtherOperationCount: " & ObjClsItem.OtherOperationCount
Text1.Text = Text1.Text & vbCrLf & "OtherTransferCount: " & ObjClsItem.OtherTransferCount
Text1.Text = Text1.Text & vbCrLf & "PageFaults: " & ObjClsItem.PageFaults
Text1.Text = Text1.Text & vbCrLf & "PageFileUsage: " & ObjClsItem.PageFileUsage
Text1.Text = Text1.Text & vbCrLf & "ParentProcessId: " & ObjClsItem.ParentProcessId
Text1.Text = Text1.Text & vbCrLf & "PeakPageFileUsage: " & ObjClsItem.PeakPageFileUsage
Text1.Text = Text1.Text & vbCrLf & "PeakVirtualSize: " & ObjClsItem.PeakVirtualSize
Text1.Text = Text1.Text & vbCrLf & "PeakWorkingSetSize: " & ObjClsItem.PeakWorkingSetSize
Text1.Text = Text1.Text & vbCrLf & "Priority: " & ObjClsItem.Priority
Text1.Text = Text1.Text & vbCrLf & "PrivatePageCount: " & ObjClsItem.PrivatePageCount
Text1.Text = Text1.Text & vbCrLf & "ProcessId: " & ObjClsItem.ProcessId
Text1.Text = Text1.Text & vbCrLf & "QuotaNonPagedPoolUsage: " & ObjClsItem.QuotaNonPagedPoolUsage
Text1.Text = Text1.Text & vbCrLf & "QuotaPagedPoolUsage: " & ObjClsItem.QuotaPagedPoolUsage
Text1.Text = Text1.Text & vbCrLf & "QuotaPeakNonPagedPoolUsage: " & ObjClsItem.QuotaPeakNonPagedPoolUsage
Text1.Text = Text1.Text & vbCrLf & "QuotaPeakPagedPoolUsage: " & ObjClsItem.QuotaPeakPagedPoolUsage
Text1.Text = Text1.Text & vbCrLf & "ReadOperationCount: " & ObjClsItem.ReadOperationCount
Text1.Text = Text1.Text & vbCrLf & "ReadTransferCount: " & ObjClsItem.ReadTransferCount
Text1.Text = Text1.Text & vbCrLf & "SessionId: " & ObjClsItem.SessionId
Text1.Text = Text1.Text & vbCrLf & "Status: " & ObjClsItem.Status
Text1.Text = Text1.Text & vbCrLf & "TerminationDate: " & ObjClsItem.TerminationDate
Text1.Text = Text1.Text & vbCrLf & "ThreadCount: " & ObjClsItem.ThreadCount
Text1.Text = Text1.Text & vbCrLf & "UserModeTime: " & ObjClsItem.UserModeTime
Text1.Text = Text1.Text & vbCrLf & "VirtualSize: " & ObjClsItem.VirtualSize
Text1.Text = Text1.Text & vbCrLf & "WindowsVersion: " & ObjClsItem.WindowsVersion
Text1.Text = Text1.Text & vbCrLf & "WorkingSetSize: " & ObjClsItem.WorkingSetSize
Text1.Text = Text1.Text & vbCrLf & "WriteOperationCount: " & ObjClsItem.WriteOperationCount
Text1.Text = Text1.Text & vbCrLf & "WriteTransferCount: " & ObjClsItem.WriteTransferCount
Text1.Text = Text1.Text & vbCrLf & "====================================================" & vbCrLf & vbCrLf & vbCrLf
Next
Err_Handler:
Set ObjClsItem = Nothing
Set WMI_ObjProps = Nothing
Set objWMIService = Nothing
If Err.Number <> 0 Then Err.Clear
End Sub
'
Private Sub Form_Resize()
Text1.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub
paix à ton âme ^^
++
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.