' // Written by Ellis Dee //
' Thanks to Matt Pietrek of MSJ and Edgemeal of vbforums.com
Option Explicit
Public Event Activity()
Public Event Idle()
Private Const ReadColor = 16761024 ' ?RGB(192, 192, 255)
Private Const WriteColor = 16744576 ' ?RGB(128, 128, 255)
Private Const InactiveColor = 6316128 ' ?RGB(96, 96, 96)
Private Const BorderColor = 0 ' ?RGB(0, 0, 0)
Private mlngRead As Long
Private mlngWrite As Long
Private mlngIdle As Long
Private mblnIndicator As Boolean
Private mblnValid As Boolean
Private mlngQuery As Long
Private mlngReadCounter As Long
Private mlngWriteCounter As Long
Private Const ERROR_SUCCESS = 0
Private Enum PDH_STATUS
PDH_CSTATUS_VALID_DATA = &H0
PDH_CSTATUS_NEW_DATA = &H1
PDH_CSTATUS_NO_MACHINE = &H800007D0
PDH_CSTATUS_NO_INSTANCE = &H800007D1
PDH_MORE_DATA = &H800007D2
PDH_CSTATUS_ITEM_NOT_VALIDATED = &H800007D3
PDH_RETRY = &H800007D4
PDH_NO_DATA = &H800007D5
PDH_CALC_NEGATIVE_DENOMINATOR = &H800007D6
PDH_CALC_NEGATIVE_TIMEBASE = &H800007D7
PDH_CALC_NEGATIVE_VALUE = &H800007D8
PDH_DIALOG_CANCELLED = &H800007D9
PDH_CSTATUS_NO_OBJECT = &HC0000BB8
PDH_CSTATUS_NO_COUNTER = &HC0000BB9
PDH_CSTATUS_INVALID_DATA = &HC0000BBA
PDH_MEMORY_ALLOCATION_FAILURE = &HC0000BBB
PDH_INVALID_HANDLE = &HC0000BBC
PDH_INVALID_ARGUMENT = &HC0000BBD
PDH_FUNCTION_NOT_FOUND = &HC0000BBE
PDH_CSTATUS_NO_COUNTERNAME = &HC0000BBF
PDH_CSTATUS_BAD_COUNTERNAME = &HC0000BC0
PDH_INVALID_BUFFER = &HC0000BC1
PDH_INSUFFICIENT_BUFFER = &HC0000BC2
PDH_CANNOT_CONNECT_MACHINE = &HC0000BC3
PDH_INVALID_PATH = &HC0000BC4
PDH_INVALID_INSTANCE = &HC0000BC5
PDH_INVALID_DATA = &HC0000BC6
PDH_NO_DIALOG_DATA = &HC0000BC7
PDH_CANNOT_READ_NAME_STRINGS = &HC0000BC8
End Enum
Private Declare Function PdhVbGetOneCounterPath Lib "PDH.DLL" (ByVal PathString As String, ByVal PathLength As Long, ByVal DetailLevel As Long, ByVal CaptionString As String) As Long
Private Declare Function PdhVbCreateCounterPathList Lib "PDH.DLL" (ByVal PERF_DETAIL As Long, ByVal CaptionString As String) As Long
Private Declare Function PdhVbGetCounterPathFromList Lib "PDH.DLL" (ByVal Index As Long, ByVal Buffer As String, ByVal BufferLength As Long) As Long
Private Declare Function PdhOpenQuery Lib "PDH.DLL" (ByVal Reserved As Long, ByVal dwUserData As Long, ByRef mlngQuery As Long) As PDH_STATUS
Private Declare Function PdhCloseQuery Lib "PDH.DLL" (ByVal mlngQuery As Long) As PDH_STATUS
Private Declare Function PdhVbAddCounter Lib "PDH.DLL" (ByVal QueryHandle As Long, ByVal CounterPath As String, ByRef CounterHandle As Long) As PDH_STATUS
Private Declare Function PdhCollectQueryData Lib "PDH.DLL" (ByVal QueryHandle As Long) As PDH_STATUS
Private Declare Function PdhVbIsGoodStatus Lib "PDH.DLL" (ByVal StatusValue As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue Lib "PDH.DLL" (ByVal CounterHandle As Long, ByRef CounterStatus As Long) As Double
Public Sub GetActivity(plngRead As Long, plngWrite As Long)
If mblnValid Then
PdhCollectQueryData (mlngQuery)
plngRead = GetCounter(mlngReadCounter) ' PhysicalDisk Total % Disk Read Time
plngWrite = GetCounter(mlngWriteCounter) ' PhysicalDisk Total % Disk Write Time
End If
End Sub
Private Function GetCounter(plngCounter As Long) As Long
Dim enStatus As PDH_STATUS
Dim dblActivity As Double
dblActivity = PdhVbGetDoubleCounterValue(plngCounter, enStatus)
' Verify that when we queried, the returned value was valid
If Not ((enStatus = PDH_CSTATUS_VALID_DATA) Or (enStatus = PDH_CSTATUS_NEW_DATA)) Then dblActivity = 0
Select Case dblActivity
Case Is < 10: GetCounter = 0
Case Is > 100: GetCounter = 5
Case Else: GetCounter = 1 + (Round(dblActivity) - 1) \ 20
End Select
End Function
Private Sub Class_Initialize()
StartMonitor
End Sub
Private Sub Class_Terminate()
StopMonitor
End Sub
Public Sub StopMonitor()
If mlngQuery Then PdhCloseQuery (mlngQuery) ' Free the PDH query
mblnValid = False
End Sub
Public Sub StartMonitor()
Dim enStatus As PDH_STATUS
enStatus = PdhOpenQuery(0, 1, mlngQuery)
If enStatus <> ERROR_SUCCESS Then Exit Sub
mblnValid = True
PdhVbAddCounter mlngQuery, "\PhysicalDisk(_Total)\% Disk Read Time", mlngReadCounter
PdhVbAddCounter mlngQuery, "\PhysicalDisk(_Total)\% Disk Write Time", mlngWriteCounter
End Sub
Public Sub Timer(ppic As PictureBox)
Dim lngNewRead As Long
Dim lngNewWrite As Long
Dim blnRedraw As Boolean
Dim blnOldIndicator As Boolean
If Not mblnValid Then Exit Sub
blnOldIndicator = mblnIndicator
Me.GetActivity lngNewRead, lngNewWrite
If lngNewRead = 0 And lngNewWrite = 0 Then
mlngIdle = mlngIdle + 1
mblnIndicator = (mlngIdle < 15)
Else
mblnIndicator = True
mlngIdle = 0
End If
If lngNewRead <> mlngRead Then
mlngRead = lngNewRead
blnRedraw = True
End If
If lngNewWrite <> mlngWrite Then
mlngWrite = lngNewWrite
blnRedraw = True
End If
If mblnIndicator Then
If blnRedraw Then
ppic.Line (0, 0)-(31, 31), BorderColor, BF
DrawIndicator ppic, mlngRead, ReadColor, 2
DrawIndicator ppic, mlngWrite, WriteColor, 17
RaiseEvent Activity
End If
ElseIf blnOldIndicator Then
RaiseEvent Idle
End If
End Sub
Private Sub DrawIndicator(ppic As PictureBox, plngActivity As Long, plngColor As Long, plngLeft As Long)
Dim lngRight As Long
Dim lngColor As Long
Dim lngY As Long
Dim i As Long
lngRight = plngLeft + 12
For i = 0 To 4
If i < plngActivity Then lngColor = plngColor Else lngColor = InactiveColor
lngY = 26 - i * 6
ppic.Line (plngLeft, lngY)-(lngRight, lngY + 3), lngColor, BF
Next
End Sub
