INFO: Collecting Performance Data Using PDH APIs from Visual Basic (296526)

MORE INFORMATION

The following sample code has a function called ConstructCounterPath() that constructs the counter path as required by the PdhAddCounter() API for the specified performance object, counter, and instance names. Command1_Click below constructs an array of counter paths that an application is interested in collecting the performance data from and then calls the CollectAndDisplayPerformanceData Visual Basic helper procedure.

CollectAndDisplayPerformanceData interfaces with PDH APIs to collect/display performance data values.

The hex error codes returned by PDH APIs are defined in the Pdhmsg.h header file.

Option Explicit

' PDH API Success Status
Private Const ERROR_SUCCESS = 0

Const PERF_SIZE_LARGE = &H100

Const PDH_FMT_LONG = &H100

Private Type PDH_COUNTER_INFO
    dwLength As Long
    dwType As Long
    CVersion As Long
    CStatus As Long
    lScale As Long
    lDefaultScale As Long
    dwUserData As Long
    dwQueryUserData As Long
    szFullPath As Long
    szMachineName As Long
    szObjectName As Long
    szInstanceName As Long
    szParentInstance As Long
    dwInstanceIndex As Long
    szCounterName As Long
    szExplainText As Long
    DataBuffer As Long
End Type

Private Type PDH_FMT_COUNTERVALUE
    CStatus As Long
    unionPadding As Long
    longValue As Long
    extraBytes As Long
End Type

Private Declare Function PdhOpenQuery Lib "pdh" Alias "PdhVbOpenQuery" _
        (ByRef hQuery As Long) As Long
Private Declare Function PdhCloseQuery Lib "pdh" _
        (ByVal hQuery As Long) As Long
Private Declare Function PdhCollectQueryData Lib "pdh" _
        (ByVal hQuery As Long) As Long
Private Declare Function PdhAddCounter Lib "pdh" Alias "PdhVbAddCounter" _
        (ByVal hQuery As Long, _
            ByVal counterPath As String, _
            ByRef hCounter As Long) As Long
Private Declare Function PdhRemoveCounter Lib "pdh" _
        (ByVal hCounter As Long) As Long
Private Declare Function PdhVbGetDoubleCounterValue Lib "pdh" _
        (ByVal hCounter As Long, _
        ByRef CounterStatus As Long) As Double
Private Declare Function PdhVbIsGoodStatus Lib "pdh" _
        (ByVal StatusValue As Long) As Long
Private Declare Function PdhGetFormattedCounterValue Lib "pdh" _
        (ByVal hCounter As Long, _
        ByVal dwFormat As Long, _
        lpdwType As Long, _
        pValue As PDH_FMT_COUNTERVALUE) As Long
Private Declare Function PdhGetCounterInfo Lib "pdh" Alias "PdhGetCounterInfoA" _
        (ByVal hCounter As Long, _
        ByVal bRetrieveExplainText As Long, _
        pdwBufferSize As Long, _
        lpBuffer As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
         (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMillseconds As Long)

Private Sub CollectAndDisplayPerformanceData(ByRef counterPath() As String)

Dim ret As Long
Dim hQuery As Long
Dim index As Long
Dim maxIndex As Long
Dim value As Double
Dim counterValue As PDH_FMT_COUNTERVALUE
Dim bufferSize As Long
Dim counterInfo As PDH_COUNTER_INFO
Dim dwType As Long

hQuery = 0

maxIndex = UBound(counterPath)
ReDim hCounters(0 To maxIndex)
ReDim counterTypes(0 To maxIndex)

' Create a PDH Query
ret = PdhOpenQuery(hQuery)
If ret <> ERROR_SUCCESS Then
    Debug.Print "PdhOpenQuery failed with error code : " & Hex(ret)
    Exit Sub
End If

' Add a counter to the query for the counterPath specified.
' If there are multiple counters to be monitored add them to
' created PDH query
For index = 0 To maxIndex
    ret = PdhAddCounter(hQuery, counterPath(index), hCounters(index))
    If ret <> ERROR_SUCCESS Then
        Debug.Print "PdhAddCounter failed with error code : " & Hex(ret)
        GoTo Cleanup
    End If
    
    'Get the counter type information for the counter created
    bufferSize = 0
    ret = PdhGetCounterInfo(hCounters(index), 0, bufferSize, ByVal 0)
    ReDim lpBuffer(bufferSize)
    ret = PdhGetCounterInfo(hCounters(index), 0, bufferSize, lpBuffer(0))
    If ret <> ERROR_SUCCESS Then
        Debug.Print "PdhGetCounterInfo failed with error code : " & Hex(ret)
        GoTo Cleanup
    End If
    CopyMemory counterInfo, lpBuffer(0), Len(counterInfo)
    counterTypes(index) = counterInfo.dwType
Next

' Collect the first snapshot of performance data for all counters.
' We ignore the first snapshot as most performance counters require two
' snapshots to get a calculated value
ret = PdhCollectQueryData(hQuery)
If ret <> ERROR_SUCCESS Then
    Debug.Print "PdhCollectQueryData failed with error code : " & Hex(ret)
    GoTo Cleanup
End If

Dim nMaxCollections As Long
Dim nCollection As Long

nCollection = 0
nMaxCollections = 10
For nCollection = 1 To nMaxCollections
    
    'Sleep for a while between each collection
    Sleep (1000)
    
    ' Collect the next snapshot of performance data.
    ret = PdhCollectQueryData(hQuery)
    If ret <> ERROR_SUCCESS Then
        Debug.Print "PdhCollectQueryData failed with error code : " & Hex(ret)
        GoTo Cleanup
    End If
    
    ' Get Calculated performance data values for each counter and display them
    For index = 0 To maxIndex
        ' Check if it is a LARGE counter type.
        If counterTypes(index) And PERF_SIZE_LARGE Then
            value = PdhVbGetDoubleCounterValue(hCounters(index), ret)
            If PdhVbIsGoodStatus(ret) = 0 Then
                Debug.Print "PdhVbGetDoubleCounterValue " & counterPath(index) & " failed with error code : " & Hex(ret)
            Else
                Debug.Print counterPath(index) & " [" & value & "]"
            End If
        Else
            ret = PdhGetFormattedCounterValue(hCounters(index), _
                        PDH_FMT_LONG, dwType, counterValue)
            If ret <> ERROR_SUCCESS Then
                Debug.Print "PdhGetFormattedCounterValue " & counterPath(index) & " failed with error code : " & Hex(ret)
            Else
                Debug.Print counterPath(index) & " [" & counterValue.longValue & "]"
            End If
        End If
    Next

Next

Cleanup:

' If hQuery has been created
If hQuery <> 0 Then
    For index = 0 To maxIndex
        ' Remove all the counters that have been added successfully, from the query
        If (hCounters(index) <> 0) Then
            ret = PdhRemoveCounter(hCounters(index))
            If ret <> ERROR_SUCCESS Then
                Debug.Print "PdhRemoveCounter failed with error code : " & Hex(ret)
            End If
        End If
    Next
    ret = PdhCloseQuery(hQuery)
    If (ret <> ERROR_SUCCESS) Then
        Debug.Print "PdhCloseQuery failed with error code : " & Hex(ret)
    End If
End If

End Sub

Private Function ConstructCounterPath(ByVal szMachineName As String, _
        ByVal szObjectName As String, ByVal szCounterName As String, ByVal szInstanceName As String) As String
        
Dim counterPath As String
    
counterPath = ""

' If szMachineName is specified
If Len(szMachineName) Then
    counterPath = "\\" + szMachineName
End If

counterPath = counterPath + "\" + szObjectName

' If szInstanceName is specified
If Len(szInstanceName) Then
    counterPath = counterPath + "(" + szInstanceName + ")"
End If

counterPath = counterPath + "\" + szCounterName

ConstructCounterPath = counterPath

End Function

Private Sub Command1_Click()

Dim counterPath(0 To 5) As String

'Performance Counters that have instance names
counterPath(0) = ConstructCounterPath("PRABAGAR4", "Processor", "% Processor Time", "0")
counterPath(1) = ConstructCounterPath("PRABAGAR4", "Process", "% Processor Time", "csrss")

'Performance Counters that DOES NOT have instance names
counterPath(2) = ConstructCounterPath("SERVERNAME", "System", "Processes", vbNullString)
counterPath(3) = ConstructCounterPath("SERVERNAME", "System", "Threads", vbNullString)
counterPath(4) = ConstructCounterPath("SERVERNAME", "Objects", "Events", vbNullString)
counterPath(5) = ConstructCounterPath("SERVERNAME", "Objects", "Mutexes", vbNullString)

CollectAndDisplayPerformanceData counterPath

End Sub