Загрузка процессора

Option Explicit
Private Const ClassName As String = "CPULoad"
Private Const Err_Initialize As Long = vbObjectError + 8001
Private Const Err_UnableToStartPerfmon As Long = vbObjectError + 8002
Private Const Err_CPUIndexOOB As Long = vbObjectError + 8003
Private Const Err_CantFindProcessorPerfMon As Long = vbObjectError + 8004
Private Const Err_CantFindCPUUsagePerfMon As Long = vbObjectError + 8005
Private Const Err_UnableToReadPDB As Long = vbObjectError + 8006
Private Declare Sub Memcopy Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SystemTime, lpFileTime As Currency) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
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 Const HKEY_DYN_DATA = &H80000006
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const REG_DWORD = 4
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_MORE_DATA = 234
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type SystemTime
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
Private Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type
Private Type PERF_INSTANCE_DEFINITION
    ByteLength As Long
    ParentObjectTitleIndex As Long
    ParentObjectInstance As Long
    UniqueID As Long
    NameOffset As Long
    NameLength As Long
End Type
Private Type PERF_COUNTER_BLOCK
    ByteLength As Long
End Type
Private Type PERF_DATA_BLOCK
    Signature As String * 4
    LittleEndian As Long
    Version As Long
    Revision As Long
    TotalByteLength As Long
    HeaderLength As Long
    NumObjectTypes As Long
    DefaultObject As Long
    SystemTime As SystemTime
    PerfTime As LARGE_INTEGER
    PerfFreq As LARGE_INTEGER
    PerTime100nSec As LARGE_INTEGER
    SystemNameLength As Long
    SystemNameOffset As Long
End Type

Private Type PERF_OBJECT_TYPE
    TotalByteLength As Long
    DefinitionLength As Long
    HeaderLength As Long
    ObjectNameTitleIndex As Long
    ObjectNameTitle As Long
    ObjectHelpTitleIndex As Long
    ObjectHelpTitle As Long
    DetailLevel As Long
    NumCounters As Long
    DefaultCounter As Long
    NumInstances As Long
    CodePage As Long
    PerfTime As LARGE_INTEGER
    PerfFreq As LARGE_INTEGER
End Type

Private Type PERF_COUNTER_DEFINITION
    ByteLength As Long
    CounterNameTitleIndex As Long
    CounterNameTitle As Long
    CounterHelpTitleIndex As Long
    CounterHelpTitle As Long
    DefaultScale As Long
    DetailLevel As Long
    CounterType As Long
    CounterSize As Long
    CounterOffset As Long
End Type

Private Const Processor_IDX_Str As String = "238"
Private Const Processor_IDX  As Long = 238
Private Const CPUUsageIDX As Long = 6
Private m_lProcessorsCount As Long
Private m_lBufferSize As Long
Private m_bIsWinNT As Boolean
Private m_bW9xCollecting As Boolean
Private m_lW9xCpuUsage As Long
Private m_hW9xCpuKey As Long
Private PDB As PERF_DATA_BLOCK
Private POT As PERF_OBJECT_TYPE
Private PCD As PERF_COUNTER_DEFINITION
Private PID As PERF_INSTANCE_DEFINITION
Private PCB As PERF_COUNTER_BLOCK
Private VI As OSVERSIONINFO
Private SysTime As Currency
Private PrevSysTime As Currency
Private m_aCounters() As Currency
Private m_aPrevCounters() As Currency

Private Const ByteIncrement As Long = 4096

Private Sub Class_Initialize()
    VI.dwOSVersionInfoSize = Len(VI)
    If GetVersionEx(VI) = 0 Then
        Err.Raise Err_Initialize, ClassName & ".Initialize", "Невозможно определить версию Windows"
    End If
    m_bIsWinNT = (VI.dwPlatformId = VER_PLATFORM_WIN32_NT)
    m_lProcessorsCount = -1
    m_lBufferSize = ByteIncrement
End Sub

Private Sub Class_Terminate()
    ReleaseCPUData
End Sub

Public Function CollectCPUData() As Boolean
    Dim H As Long, R As Long
    Dim aBuf() As Byte, lAllocSz As Long
    Dim lSrc As Long, lDest As Long
    Dim ptrPOT As Long, ptrPCB As Long
    Dim i As Long, lCPU As Long
    Dim ST As Currency
    Dim sInstanceName As String

    If m_bIsWinNT = True Then       'Если система - NT
        lAllocSz = m_lBufferSize
        ReDim aBuf(1 To lAllocSz) As Byte
        While RegQueryValueEx(HKEY_PERFORMANCE_DATA, Processor_IDX_Str, 0&, 0&, aBuf(1), m_lBufferSize) = ERROR_MORE_DATA
            lAllocSz = lAllocSz + ByteIncrement
            ReDim aBuf(1 To lAllocSz) As Byte
            m_lBufferSize = lAllocSz
        Wend
        lDest = VarPtr(PDB)
        lSrc = VarPtr(aBuf(1))
        Memcopy ByVal lDest, ByVal lSrc, LenB(PDB)
        m_lBufferSize = lAllocSz
              If PDB.Signature <> "PERF" Then Err.Raise Err_UnableToReadPDB, ClassName & ".CollectCPUData()", "Невозможно считать значения загрузки процессора"
        lDest = VarPtr(POT)
        lSrc = VarPtr(aBuf(1)) + PDB.HeaderLength
        For i = 1 To PDB.NumObjectTypes
            Memcopy ByVal lDest, ByVal lSrc, LenB(POT)
            ptrPOT = lSrc
            If POT.ObjectNameTitleIndex = Processor_IDX Then Exit For
            lSrc = lSrc + POT.TotalByteLength
        Next i
        If POT.ObjectNameTitleIndex <> Processor_IDX Then Err.Raise Err_CantFindProcessorPerfMon, ClassName & ".CollectData", "Невозможно найти объект загрузки 'Processor'"
        If m_lProcessorsCount < 1 Then m_lProcessorsCount = GetCPUCount()
        lDest = VarPtr(PCD)
        lSrc = lSrc + POT.HeaderLength
        For i = 1 To POT.NumCounters
            Memcopy ByVal lDest, ByVal lSrc, LenB(PCD)
            If PCD.CounterNameTitleIndex = CPUUsageIDX Then Exit For
            lSrc = lSrc + PCD.ByteLength
        Next i
        If PCD.CounterNameTitleIndex <> CPUUsageIDX Then Err.Raise Err_CantFindCPUUsagePerfMon, ClassName & ".CollectData", "Невозможно найти счетчик загрузки процессора '% CPU usage'"
        lSrc = ptrPOT + POT.DefinitionLength
        For i = 1 To POT.NumInstances
            lDest = VarPtr(PID)
            Memcopy ByVal lDest, ByVal lSrc, LenB(PID)
            sInstanceName = Space(PID.NameLength - 2)
            Memcopy ByVal sInstanceName, ByVal lSrc + PID.NameOffset, PID.NameLength - 2
            sInstanceName = StrConv(sInstanceName, vbFromUnicode)
            lSrc = lSrc + PID.ByteLength
            lDest = VarPtr(PCB)
            Memcopy ByVal lDest, ByVal lSrc, LenB(PCB)
            ptrPCB = lSrc
            If IsNumeric(sInstanceName) Then
                lCPU = CLng(sInstanceName)
                m_aPrevCounters(lCPU) = m_aCounters(lCPU)
                Memcopy ByVal VarPtr(m_aCounters(lCPU)), ByVal ptrPCB + PCD.CounterOffset, LenB(m_aCounters(lCPU))
            End If
            lSrc = lSrc + PCB.ByteLength
        Next i
         
        PrevSysTime = SysTime
        SystemTimeToFileTime PDB.SystemTime, ST
        SysTime = ST

    Else
        If Not m_bW9xCollecting Then
            If Not RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StartStat", 0&, KEY_ALL_ACCESS, H) = ERROR_SUCCESS Then
                Err.Raise Err_UnableToStartPerfmon, ClassName & ".CollectCPRData()", "Невозможно запустить мониторинг"
            End If
            Call RegQueryValueEx(H, "KERNEL\CPUUsage", 0&, REG_DWORD, m_lW9xCpuUsage, LenB(m_lW9xCpuUsage))
            Call RegCloseKey(H)
            If Not RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StatData", 0&, KEY_READ, m_hW9xCpuKey) = ERROR_SUCCESS Then
                Err.Raise Err_UnableToReadPDB, ClassName & ".CollectCPUData()", "Невозможно прочитать значения мониторинга"
            End If
            m_bW9xCollecting = True
        End If
        Call RegQueryValueEx(m_hW9xCpuKey, "KERNEL\CPUUsage", 0&, REG_DWORD, m_lW9xCpuUsage, LenB(m_lW9xCpuUsage))
    End If
End Function

Public Function GetCPUCount() As Long
    Dim SI As SYSTEM_INFO
    If m_lProcessorsCount < 1 Then
        GetSystemInfo SI
        GetCPUCount = SI.dwNumberOrfProcessors
        m_lProcessorsCount = SI.dwNumberOrfProcessors
        ReDim m_aPrevCounters(0 To m_lProcessorsCount - 1) As Currency
        ReDim m_aCounters(0 To m_lProcessorsCount - 1) As Currency
    Else
        GetCPUCount = m_lProcessorsCount
    End If
End Function
Public Function GetCPUUsage(Optional ByVal CPU_Index As Long = 1) As Long
CPU_Index = CPU_Index - 1
If m_bIsWinNT Then
If m_lProcessorsCount < 0 Then CollectCPUData
If (CPU_Index >= m_lProcessorsCount) Or (CPU_Index < 0) Then Err.Raise Err_CPUIndexOOB, ClassName & ".GetCPUUsage()", "Номер процессора выходит за границы"
If PrevSysTime = SysTime Then
            GetCPUUsage = 0
        Else
            GetCPUUsage = CLng(100 * (1 - (m_aCounters(CPU_Index) - m_aPrevCounters(CPU_Index)) / (SysTime - PrevSysTime)))
        End If
    Else
        If Not CPU_Index = 0 Then Err.Raise Err_CPUIndexOOB, ClassName & ".GetCPUUsage()", "Номер процессора выходит за границы"
         
        If Not m_bW9xCollecting Then CollectCPUData
        GetCPUUsage = m_lW9xCpuUsage
    End If
End Function
Private Sub ReleaseCPUData()
    Dim H As Long
    If m_bIsWinNT Then Exit Sub
    If Not m_bW9xCollecting Then Exit Sub
     
    m_bW9xCollecting = False
    Call RegCloseKey(m_hW9xCpuKey)
    m_hW9xCpuKey = 0
     
    If Not RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StopStat", 0, KEY_ALL_ACCESS, H) = ERROR_SUCCESS Then Exit Sub

    Call RegQueryValueEx(H, "KERNEL\CPUUsage", 0&, REG_DWORD, m_lW9xCpuUsage, LenB(m_lW9xCpuUsage))
    Call RegCloseKey(H)
End Sub

Dim Usage As Byte
CPU.CollectCPUData
Usage = CPU.GetCPUUsage

Dim objWMI 'As Object
Dim objCollection 'As Object
Dim curObj 'As Object
Dim numCPU 'As Byte
Dim xPercent() 'As Byte
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objCollection = objWMI.ExecQuery("Select * From Win32_Processor")
numCPU = objCollection.Count
ReDim xPercent(numCPU)
i = 0
listRes = vbNullString
For Each curObj In objCollection
    xPercent(i) = curObj.LoadPercentage
    listRes = listRes & i + 1 & ": " & xPercent(i) & "%" & vbCr
    i = i + 1
Next 'curObj
MsgBox "Загрузка процессоров в момент тестирования: " & vbCr & listRes