Date de création : 30/03/2007 à 17:39:00 7 Commentaire(s)

sebdraluorg

Par simplicité j'ai fais un module de classe c'est beaucoup plus simple que via un module...
Niveau optimisation on peut surement faire mieux, donc si vous avez des suggestions n'hesitez pas.

Utilisation:

Dim CpuUsage As New ClsProcCpuUsage

'On indique le ProcessId du processus que l'on veut
CpuUsage.SetPid = Pid

'Et puis on peut recuperer l'utilisation cpu quand on veut:
CpuUsage.GetCpuUsage

Option Explicit

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type SYSTEM_INFO
        dwOemID As Long
        dwPageSize As Long
        lpMinimumApplicationAddress As Long
        lpMaximumApplicationAddress As Long
        dwActiveProcessorMask As Long
        dwNumberOrfProcessors As Long
        dwProcessorType As Long
        dwAllocationGranularity As Long
        dwReserved As Long
End Type

Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Private Declare Function GetProcessTimes Lib "kernel32" (ByVal hProcess As Long, lpCreationTime As Long, lpExitTime As Long, lpKernelTime As FILETIME, lpUserTime As FILETIME) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const PROCESS_QUERY_INFORMATION As Long = &H400

Private bRet                As Boolean

Private ftKernel            As FILETIME
Private ftUser              As FILETIME
Private ftKernelStart      As FILETIME
Private ftUserStart        As FILETIME

Private ProcessId          As Long
Private ProcessorCount      As Long

Private Const NanoSec      As Long = 10000000

Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Private curStart    As Currency
Private curEnd      As Currency
Private curFreq    As Currency

Public Function SetPid(ByVal PID As Long)
   
    ProcessId = PID
    InitialiseCounter
   
End Function

Public Function GetCpuUsage() As Single

    Dim ProcTime    As Double
    Dim hProcess    As Long
   
    If ProcessId > 0 Then
        GetProcTimes
        QueryPerformanceCounter curEnd
        ProcTime = (ftKernel.dwLowDateTime - ftKernelStart.dwLowDateTime + (ftUser.dwLowDateTime - ftUserStart.dwLowDateTime))
        ProcTime = CDbl(ProcTime / ProcessorCount) / CDbl(((curEnd - curStart) / curFreq))
        QueryPerformanceCounter curStart
        GetCpuUsage = (ProcTime / NanoSec) * 100
        ftKernelStart = ftKernel
        ftUserStart = ftUser
    End If
   
End Function

Private Sub InitialiseCounter()

    Dim SysInfo As SYSTEM_INFO
   
    GetSystemInfo SysInfo
    ProcessorCount = SysInfo.dwNumberOrfProcessors
    QueryPerformanceFrequency curFreq

    GetProcTimes
    QueryPerformanceCounter curStart

    ftKernelStart = ftKernel
    ftUserStart = ftUser
   
End Sub

Private Sub GetProcTimes()

    Dim hProcess As Long
   
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0&, ProcessId)
    If hProcess Then
        bRet = GetProcessTimes(hProcess, 0&, 0&, ftKernel, ftUser)
        CloseHandle hProcess
    End If
   
End Sub

Voici l'historique des modifications de ce code :

Le 31/03/2007 par sebdraluorg : Recuperation du pourcentage en type Single au lieu de long (dapres la suggestion de Mad)

Vous devez être connecté pour pouvoir poster un commentaire.