Private Type LARGE_INTEGER lowpart As Long highpart As Long End TypePrivate Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As _ Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As LongPrivate Const REG_DWORD = 4 Private Const HKEY_DYN_DATA = &H80000006Private 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 LongPrivate Declare Function RegOpenKey Lib "advapi32.dll" _ Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal _ lpSubKey As String, phkResult As Long) As LongPrivate Declare Function RegCloseKey Lib "advapi32.dll" _ (ByVal hKey As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter _ As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As _ Long) As LongDim mix As Long Dim miy As LongPrivate Sub Command1_Click() End End SubPrivate Sub Form_Load() '将Form1的位置设置到屏幕右上角 Form1.Top = 1 Form1.Left = Screen.Width - Form1.WidthCall InitCPU Call OnTop End SubPrivate Sub Form_Resize() Picture1.Width = Me.ScaleWidth mix = Picture1.Width \ 30 End SubPrivate Sub Timer1_Timer() Dim lData As Long, lType As Long, lSize As Long Dim hKey As Long Dim l As Long Dim astr As StringQry = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StatData", hKey)
statbar = Int(lData / 10) Picture1.Cls Picture1.Line (0, 0)-(Int(Picture1.Width * (lData / 100)), Picture1.Width), 1, BF astr = "%" + Str(lData) l = TextOut(Picture1.hdc, mix, 0, astr, Len(astr))Qry = RegCloseKey(hKey)End SubPrivate Sub InitCPU() Dim lData As Long, lType As Long, lSize As Long Dim hKey As Long Qry = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StartStat", hKey) If Qry <> 0 Then MsgBox "注册表打开错误!" End End If
lType = REG_DWORD lSize = 4 Qry = RegQueryValueEx(hKey, "KERNEL\CPUUsage", 0, lType, lData, lSize) Qry = RegCloseKey(hKey)End SubPrivate Sub OnTop() Const SWP_NOMOVE = &H2 Const SWP_NOSIZE = &H1 Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE Const HWND_TOPMOST = -1 Const HWND_NOTOPMOST = -2If SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS) = True Then success% = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS) End If End Sub提供一个NT的(取自网友文章) ------------ '建一个类,名称CPUOption 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 -------------- ’添一个文本框,和一个timer 1000msOption Explicit Dim lngCPU As New CPU Private Sub Timer1_Timer() Text1 = lngCPU.Query End Sub
http://www.applevb.com/sourcecode/cpuinfo.zip
lowpart As Long
highpart As Long
End TypePrivate Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As _
Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As LongPrivate Const REG_DWORD = 4
Private Const HKEY_DYN_DATA = &H80000006Private 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 LongPrivate Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal _
lpSubKey As String, phkResult As Long) As LongPrivate Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter _
As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As _
Long) As LongDim mix As Long
Dim miy As LongPrivate Sub Command1_Click()
End
End SubPrivate Sub Form_Load()
'将Form1的位置设置到屏幕右上角
Form1.Top = 1
Form1.Left = Screen.Width - Form1.WidthCall InitCPU
Call OnTop
End SubPrivate Sub Form_Resize()
Picture1.Width = Me.ScaleWidth
mix = Picture1.Width \ 30
End SubPrivate Sub Timer1_Timer()
Dim lData As Long, lType As Long, lSize As Long
Dim hKey As Long
Dim l As Long
Dim astr As StringQry = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StatData", hKey)
If Qry <> 0 Then
MsgBox "注册表打开错误!"
End
End If
lType = REG_DWORD
lSize = 4
'从注册表中获得CPU的占用率
Qry = RegQueryValueEx(hKey, "KERNEL\CPUUsage", _
0, lType, lData, lSize)
statbar = Int(lData / 10)
Picture1.Cls
Picture1.Line (0, 0)-(Int(Picture1.Width * (lData / 100)), Picture1.Width), 1, BF
astr = "%" + Str(lData)
l = TextOut(Picture1.hdc, mix, 0, astr, Len(astr))Qry = RegCloseKey(hKey)End SubPrivate Sub InitCPU()
Dim lData As Long, lType As Long, lSize As Long
Dim hKey As Long
Qry = RegOpenKey(HKEY_DYN_DATA, "PerfStats\StartStat", hKey)
If Qry <> 0 Then
MsgBox "注册表打开错误!"
End
End If
lType = REG_DWORD
lSize = 4
Qry = RegQueryValueEx(hKey, "KERNEL\CPUUsage", 0, lType, lData, lSize)
Qry = RegCloseKey(hKey)End SubPrivate Sub OnTop()
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2If SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS) = True Then
success% = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
End If
End Sub提供一个NT的(取自网友文章)
------------
'建一个类,名称CPUOption 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
--------------
’添一个文本框,和一个timer 1000msOption Explicit
Dim lngCPU As New CPU
Private Sub Timer1_Timer()
Text1 = lngCPU.Query
End Sub
http://www.mvps.org/vbnet/code/wmi/wmiprocessor.htm
希望能够帮得上你.