home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / FIRE_GDI+179010952004.psc / clsCPULoad.cls < prev    next >
Text File  |  2004-09-05  |  5KB  |  213 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsCPULoad"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' Code by Benjamin Kunz. For more information visit:
  15. ' http://www.vbarchiv.net/archiv/tipp_1080.html
  16.  
  17. Option Explicit
  18.  
  19. Private Declare Function RegQueryValueEx& Lib "advapi32.dll" _
  20.   Alias "RegQueryValueExA" ( _
  21.   ByVal hKey&, _
  22.   ByVal lpValueName$, _
  23.   ByVal lpReserved&, _
  24.   lpType&, _
  25.   lpData As Any, _
  26.   lpcbData&)
  27.         
  28. Private Declare Function RegOpenKey& Lib "advapi32.dll" _
  29.   Alias "RegOpenKeyA" ( _
  30.   ByVal hKey&, _
  31.   ByVal lpSubKey$, _
  32.   phkResult&)
  33.         
  34. Private Declare Function RegCloseKey& Lib "advapi32.dll" ( _
  35.   ByVal hKey&)
  36.  
  37. Private Declare Sub CopyMemory Lib "kernel32.dll" _
  38.   Alias "RtlMoveMemory" ( _
  39.   Dest As Any, _
  40.   Src As Any, _
  41.   ByVal Length As Long)
  42.         
  43. Private Declare Function PdhOpenQuery Lib "PDH.DLL" ( _
  44.   ByVal Reserved As Long, _
  45.   ByVal dwUserData As Long, _
  46.   ByRef hQuery As Long) As Long
  47.         
  48. Private Declare Function PdhCloseQuery Lib "PDH.DLL" ( _
  49.   ByVal hQuery As Long) As Long
  50.         
  51. Private Declare Function PdhVbAddCounter Lib "PDH.DLL" ( _
  52.   ByVal QueryHandle As Long, _
  53.   ByVal CounterPath As String, _
  54.   ByRef CounterHandle As Long) As Long
  55.         
  56. Private Declare Function PdhCollectQueryData Lib "PDH.DLL" ( _
  57.   ByVal QueryHandle As Long) As Long
  58.         
  59. Private Declare Function PdhVbGetDoubleCounterValue Lib "PDH.DLL" ( _
  60.   ByVal CounterHandle As Long, _
  61.   ByRef CounterStatus As Long) As Double
  62.  
  63. Private Declare Function GetVersionEx Lib "kernel32" _
  64.   Alias "GetVersionExA" ( _
  65.   VersionInfo As OSVERSIONINFOEX) As Long
  66.  
  67. Private Const OSVERSIONINFOSIZE = 148
  68.  
  69. Private Const PDH_CSTATUS_VALID_DATA = &H0
  70. Private Const PDH_CSTATUS_NEW_DATA = &H1
  71. Private Const ERROR_SUCCESS = 0
  72. Private Const VER_PLATFORM_WIN32_NT = 2
  73.  
  74. Private Type OSVERSIONINFOEX
  75.   dwOSVersionInfoSize As Long
  76.   dwMajorVersion As Long
  77.   dwMinorVersion As Long
  78.   dwBuildNumber As Long
  79.   dwPlatformId As Long
  80.   szCSDVersion As String * 128
  81.   wServicePackMajor As Integer
  82.   wServicePackMinor As Integer
  83.   wSuiteMask As Integer
  84.   bProductType As Byte
  85.   bReserved As Byte
  86. End Type
  87.  
  88. Private hQuery As Long
  89. Private hCounter As Long
  90. Private RetVal As Long
  91.  
  92. Private Stack() As Long
  93. Private StackPointer As Long
  94. Private m_StackSize As Long
  95. Private m_Sum As Long
  96.  
  97. Private m_BandWidth As Long
  98.  
  99. Private Sub Class_Initialize()
  100.  
  101.   m_StackSize = 5
  102.   ReDim Stack(0 To m_StackSize - 1)
  103.   StackPointer = 0
  104.        
  105.   If IsNT Then
  106.     RetVal = PdhOpenQuery(0, 1, hQuery)
  107.     If RetVal = 0 Then
  108.       ' Define performance-counter
  109.       RetVal = PdhVbAddCounter(hQuery, _
  110.         "\Prozessor(0)\Prozessorzeit (%)", hCounter)
  111.       
  112.       ' Close Query on Error
  113.       If RetVal <> 0 Then PdhCloseQuery hQuery
  114.     End If
  115.   End If
  116. End Sub
  117.  
  118. Private Sub Class_Terminate()
  119.   ' Close Query
  120.   If IsNT Then PdhCloseQuery hQuery
  121. End Sub
  122.  
  123. ' NT-System?
  124. Private Function IsNT() As Boolean
  125.   Static VerInfo As OSVERSIONINFOEX, bOsVersionInfoEx As Long
  126.   Static Flag As Boolean, NT As Boolean
  127.  
  128.   If Not Flag Then
  129.     VerInfo.dwOSVersionInfoSize = Len(VerInfo)
  130.     bOsVersionInfoEx = GetVersionEx(VerInfo)
  131.         
  132.     If bOsVersionInfoEx = 0 Then
  133.       VerInfo.dwOSVersionInfoSize = OSVERSIONINFOSIZE
  134.       GetVersionEx VerInfo
  135.     End If
  136.  
  137.     NT = (VerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT)
  138.     Flag = True
  139.   End If
  140.         
  141.   IsNT = NT
  142. End Function
  143.  
  144. Public Property Get StackSize() As Long
  145.   StackSize = m_StackSize
  146. End Property
  147.  
  148. Public Property Let StackSize(ByRef NewStackSize As Long)
  149.   m_StackSize = NewStackSize
  150.   ReDim Stack(0 To m_StackSize - 1)
  151.   StackPointer = 0
  152. End Property
  153.  
  154. Private Sub PushBandWidth(ByRef NewBandWidth As Long)
  155.   Static u As Long
  156.     
  157.   u = UBound(Stack)
  158.   If StackPointer <= u Then
  159.     Stack(StackPointer) = NewBandWidth
  160.     m_Sum = m_Sum + NewBandWidth
  161.     StackPointer = StackPointer + 1
  162.         
  163.   Else
  164.     m_Sum = m_Sum - Stack(0) + NewBandWidth
  165.     Call CopyMemory(Stack(0), Stack(1), u * 4)
  166.     Stack(u) = NewBandWidth
  167.  
  168.   End If
  169.   m_BandWidth = m_Sum / StackPointer
  170. End Sub
  171.  
  172. Private Function GetValue9x() As Long
  173.   Dim V As Long
  174.   Static hK As Long, sK As String
  175.   Const KDyn& = &H80000006
  176.     
  177.   sK = IIf(hK = 0, "PerfStats\StartStat", "PerfStats\StatData")
  178.   If RegOpenKey(KDyn, sK, hK) Then Exit Function
  179.  
  180.   Call RegQueryValueEx(hK, "KERNEL\CPUUsage", 0, 4, V, 4)
  181.   Call RegCloseKey(hK)
  182.         
  183.   PushBandWidth V
  184.   GetValue9x = m_BandWidth
  185. End Function
  186.  
  187. Private Function GetValueNT() As Long
  188.   Dim dblValue As Double
  189.   Dim pdhStatus As Long
  190.  
  191.   PdhCollectQueryData hQuery
  192.   dblValue = PdhVbGetDoubleCounterValue(hCounter, pdhStatus)
  193.         
  194.   ' Get value of counter
  195.   If (pdhStatus = PDH_CSTATUS_VALID_DATA) Or _
  196.     (pdhStatus = PDH_CSTATUS_NEW_DATA) Then
  197.     
  198.     PushBandWidth CLng(dblValue)
  199.     GetValueNT = m_BandWidth
  200.   End If
  201. End Function
  202.  
  203. ' Returns CPU-Load
  204. Public Property Get Value() As Long
  205.   If IsNT Then
  206.     Value = GetValueNT
  207.   Else
  208.     Value = GetValue9x
  209.   End If
  210. End Property
  211.  
  212.  
  213.