Помогите пожалуста... 4-е сутки маюсь...
под 98 и Ме определял через реестр (HKEY_DYN_DATA). Но в XP зачем то этот раздел убрали

Нужно определить загрузку в %.
Заранее спасибо.
'clsCPUUsageNT- copyright й 2001, The KPD-Team
'Visit our site at http://www.allapi.net
'or email us at KPDTeam@allapi.net
Option Explicit
Private Const SYSTEM_BASICINFORMATION = 0&
Private Const SYSTEM_PERFORMANCEINFORMATION = 2&
Private Const SYSTEM_TIMEINFORMATION = 3&
Private Const NO_ERROR = 0
Private Type LARGE_INTEGER
dwLow As Long
dwHigh As Long
End Type
Private Type SYSTEM_BASIC_INFORMATION
dwUnknown1 As Long
uKeMaximumIncrement As Long
uPageSize As Long
uMmNumberOfPhysicalPages As Long
uMmLowestPhysicalPage As Long
uMmHighestPhysicalPage As Long
uAllocationGranularity As Long
pLowestUserAddress As Long
pMmHighestUserAddress As Long
uKeActiveProcessors As Long
bKeNumberProcessors As Byte
bUnknown2 As Byte
wUnknown3 As Integer
End Type
Private Type SYSTEM_PERFORMANCE_INFORMATION
liIdleTime As LARGE_INTEGER
dwSpare(0 To 75) As Long
End Type
Private Type SYSTEM_TIME_INFORMATION
liKeBootTime As LARGE_INTEGER
liKeSystemTime As LARGE_INTEGER
liExpTimeZoneBias As LARGE_INTEGER
uCurrentTimeZoneId As Long
dwReserved As Long
End Type
Private Declare Function NtQuerySystemInformation Lib "ntdll" (ByVal dwInfoType As Long, ByVal lpStructure As Long, ByVal dwSize As Long, ByVal dwReserved As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private liOldIdleTime As LARGE_INTEGER
Private liOldSystemTime As LARGE_INTEGER
Public Sub Initialize()
Dim SysTimeInfo As SYSTEM_TIME_INFORMATION
Dim SysPerfInfo As SYSTEM_PERFORMANCE_INFORMATION
Dim Ret As Long
'get new system time
Ret = NtQuerySystemInformation(SYSTEM_TIMEINFORMATION, VarPtr(SysTimeInfo), LenB(SysTimeInfo), 0&)
If Ret <> NO_ERROR Then
Debug.Print "Error while initializing the system's time!", vbCritical
Exit Sub
End If
'get new CPU's idle time
Ret = NtQuerySystemInformation(SYSTEM_PERFORMANCEINFORMATION, VarPtr(SysPerfInfo), LenB(SysPerfInfo), ByVal 0&)
If Ret <> NO_ERROR Then
Debug.Print "Error while initializing the CPU's idle time!", vbCritical
Exit Sub
End If
'store new CPU's idle and system time
liOldIdleTime = SysPerfInfo.liIdleTime
liOldSystemTime = SysTimeInfo.liKeSystemTime
End Sub
Public Function Query() As Long
Dim SysBaseInfo As SYSTEM_BASIC_INFORMATION
Dim SysPerfInfo As SYSTEM_PERFORMANCE_INFORMATION
Dim SysTimeInfo As SYSTEM_TIME_INFORMATION
Dim dbIdleTime As Currency
Dim dbSystemTime As Currency
Dim Ret As Long
Query = -1
'get number of processors in the system
Ret = NtQuerySystemInformation(SYSTEM_BASICINFORMATION, VarPtr(SysBaseInfo), LenB(SysBaseInfo), 0&)
If Ret <> NO_ERROR Then
Debug.Print "Error while retrieving the number of processors!", vbCritical
Exit Function
End If
'get new system time
Ret = NtQuerySystemInformation(SYSTEM_TIMEINFORMATION, VarPtr(SysTimeInfo), LenB(SysTimeInfo), 0&)
If Ret <> NO_ERROR Then
Debug.Print "Error while retrieving the system's time!", vbCritical
Exit Function
End If
'get new CPU's idle time
Ret = NtQuerySystemInformation(SYSTEM_PERFORMANCEINFORMATION, VarPtr(SysPerfInfo), LenB(SysPerfInfo), ByVal 0&)
If Ret <> NO_ERROR Then
Debug.Print "Error while retrieving the CPU's idle time!", vbCritical
Exit Function
End If
'CurrentValue = NewValue - OldValue
dbIdleTime = LI2Currency(SysPerfInfo.liIdleTime) - LI2Currency(liOldIdleTime)
dbSystemTime = LI2Currency(SysTimeInfo.liKeSystemTime) - LI2Currency(liOldSystemTime)
'CurrentCpuIdle = IdleTime / SystemTime
If dbSystemTime <> 0 Then dbIdleTime = dbIdleTime / dbSystemTime
'CurrentCpuUsage% = 100 - (CurrentCpuIdle * 100) / NumberOfProcessors
dbIdleTime = 100 - dbIdleTime * 100 / SysBaseInfo.bKeNumberProcessors + 0.5
Query = Int(dbIdleTime)
'store new CPU's idle and system time
liOldIdleTime = SysPerfInfo.liIdleTime
liOldSystemTime = SysTimeInfo.liKeSystemTime
End Function
Private Function LI2Currency(liInput As LARGE_INTEGER) As Currency
CopyMemory LI2Currency, liInput, LenB(liInput)
End Function
Public Sub Terminate()
'nothing to do
End Sub
'clsCPUUsage - copyright й 2001, The KPD-Team
'Visit our site at http://www.allapi.net
'or email us at KPDTeam@allapi.net
Option Explicit
Private Const STANDARD_RIGHTS_ALL = &H1F0000
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 READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const HKEY_DYN_DATA = &H80000006
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 Const ERROR_SUCCESS = 0&
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 Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private hKey As Long, dwDataSize As Long, dwCpuUsage As Byte, dwType As Long
Public Sub Initialize()
'start the counter by reading the value of the 'StartStat' key
If RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StartStat", 0, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then
Debug.Print "Error while initializing counter"
Exit Sub
End If
dwDataSize = 4 'Length of Long
RegQueryValueEx hKey, "KERNEL\CPUUsage", ByVal 0&, dwType, dwCpuUsage, dwDataSize
RegCloseKey hKey
'get current counter's value
If RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StatData", 0, KEY_READ, hKey) <> ERROR_SUCCESS Then
Debug.Print "Error while opening counter key"
Exit Sub
End If
End Sub
Public Function Query() As Long
dwDataSize = 4 'size of Long
'Query the counter
RegQueryValueEx hKey, "KERNEL\CPUUsage", ByVal 0&, dwType, dwCpuUsage, dwDataSize
Query = CLng(dwCpuUsage)
End Function
Public Sub Terminate()
RegCloseKey hKey
'stopping the counter
If RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StopStat", 0, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then
Debug.Print "Error while stopping counter"
Exit Sub
End If
dwDataSize = 4 'length of Long
RegQueryValueEx hKey, "KERNEL\CPUUsage", ByVal 0&, dwType, dwCpuUsage, dwDataSize
RegCloseKey hKey
End Sub
|kerish| писал(а):Я бы выложил тебе пример, но на форуме косяк какой-то. Файлы не выкладываются. По-крайней мере у меня.
Сейчас этот форум просматривают: Google-бот, SemrushBot и гости: 10