パフォーマンスモニタ VBA編その３

・パフォーマンスオブジェクト・カウンタを指定してモニタしてみる

今回もVC++の場合と同様にクラスにして後で使えるようにします。VBエディタからクラスモジュールを追加してプロパティウィンドウから適当な名前をつけてください。以下CPerfMoniとして進めます。出来たクラスモジュールに以下を書いてください。

Option Explicit

'問合せ初期化
Private Declare Function PdhOpenQuery Lib "pdh" Alias "PdhVbOpenQuery" _
    (hQuery As Long) As Long

'問合せClose
Private Declare Function PdhCloseQuery Lib "pdh" _
    (ByVal hQuery As Long) As Long

'Performance Data収集
Private Declare Function PdhCollectQueryData Lib "pdh" _
    (ByVal hQuery As Long) As Long

'問合せにCounter追加
Private Declare Function PdhAddCounter Lib "pdh" Alias "PdhVbAddCounter" _
    (ByVal hQuery As Long, _
     ByVal szFullCounterPath As String, _
     phCounter As Long) As Long

'問合せからCounter削除
Private Declare Function PdhRemoveCounter Lib "pdh" _
    (ByVal hCounter As Long) As Long

'Counter情報収集
Private Declare Function PdhGetCounterInfo Lib "pdh" Alias "PdhGetCounterInfoA" _
    (ByVal hCounter As Long, _
     ByVal bRetrieveExplainText As Boolean, _
     pdwBufferSize As Long, _
     lpBuffer As Any) As Long

'PdhCounterInforで受取る構造体
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

'Counterのデータサイズ
Private Const PERF_SIZE_LARGE = &H100   '0x00000100  // 64 bit field

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
     Source As Any, _
     ByVal Length As Long)

'Double型のPerformance Data取得
Private Declare Function PdhVbGetDoubleCounterValue Lib "pdh" _
    (ByVal hCounter As Long, _
     CounterStatus As Long) As Double

'収集データの有効性検査
Private Declare Function PdhVbIsGoodStatus Lib "pdh" _
    (ByVal StatusValue As Long) As Long

'Performance Data取得
Private Declare Function PdhGetFormattedCounterValue Lib "pdh" _
    (ByVal hCounter As Long, _
     ByVal dwFormat As Long, _
     lpdwType As Long, _
     pValue As PDH_FMT_COUNTERVALUE) As Long

'PdhGetFormattedCounterValueで受取る構造体
Private Type PDH_FMT_COUNTERVALUE
    CStatus      As Long
    unionPadding As Long
    longValue    As Long
    extraBytes   As Long
End Type

Private Const PDH_CSTATUS_VALID_DATA = &H0  '((DWORD)0x00000000L)
Private Const PDH_CSTATUS_NEW_DATA = &H1    '((DWORD)0x00000001L)

Private Const PDH_FMT_LONG = &H100

'-----------------------------------------------------------
'メンバ変数
Private vmlHQuery    As Long
Private vmlHCounter  As Long
Private vmlCntrType  As Long

'コンストラクタ
Private Sub Class_Initialize()
    vmlHQuery = 0: vmlHCounter = 0: vmlCntrType = 0

    PdhOpenQuery vmlHQuery
End Sub

'デストラクタ
Private Sub Class_Terminate()
    If vmlHCounter <> 0 Then PdhRemoveCounter vmlHCounter
    If vmlHQuery <> 0 Then PdhCloseQuery vmlHQuery
End Sub

'カウンタの追加(以前のカウンタの削除)
Public Function AddCounter(argsObject As String, _
                           argsCounter As String, _
                           Optional argsInstance As String = "", _
                           Optional argsParentInst As String = "", _
                           Optional arglInstanceIdx As Long = -1) As Boolean

    Dim vlHOldCounter    As Long
    Dim vsCounterPath    As String
    Dim vlSizeInfo       As Long
    Dim vcBufInfo()      As Byte
    Dim vtCounterInfo    As PDH_COUNTER_INFO

    '前カウンタへのハンドルの保存
    vlHOldCounter = vmlHCounter

    'カウンタパス作成
    vsCounterPath = "\" & argsObject
    If argsInstance <> "" Then
        vsCounterPath = vsCounterPath & "("

        If argsParentInst <> "" Then
            vsCounterPath = vsCounterPath & argsParentInst & "/"
        End If

        vsCounterPath = vsCounterPath & argsInstance

        If arglInstanceIdx > -1 Then
            vsCounterPath = vsCounterPath & "#" & arglInstanceIdx
        End If

        vsCounterPath = vsCounterPath & ")"
    End If
    vsCounterPath = vsCounterPath & "\" & argsCounter

    'カウンタの追加
    If PdhAddCounter(vmlHQuery, vsCounterPath, vmlHCounter) <> 0 Then
        Exit Function
    End If

    Do
        'カウンタ情報の収集
        PdhGetCounterInfo vmlHCounter, False, vlSizeInfo, ByVal 0

        ReDim vcBufInfo(vlSizeInfo)
        If PdhGetCounterInfo(vmlHCounter, False, vlSizeInfo, vcBufInfo(0)) <> 0 Then 
            Exit Do
        End If

        CopyMemory vtCounterInfo, vcBufInfo(0), Len(vtCounterInfo)
        vmlCntrType = vtCounterInfo.dwType

        'データの収集
        If PdhCollectQueryData(vmlHQuery) <> 0 Then Exit Do

        '前カウンタの削除
        If vlHOldCounter <> 0 Then PdhRemoveCounter vlHOldCounter

        AddCounter = True: Exit Function
    Loop

    PdhRemoveCounter vmlHCounter
    vmlHCounter = vlHOldCounter

End Function

'パフォーマンスデータ取得
Public Function GetCounterVal(argvVal As Variant) As Boolean
    Dim vtFmtVal     As PDH_FMT_COUNTERVALUE
    Dim vlStatus     As Long

    'Performance Data収集
    If PdhCollectQueryData(vmlHQuery) <> 0 Then
        argvVal = 0: Exit Function
    End If

    'Counterのデータサイズが64bitの場合
    If vmlCntrType And PERF_SIZE_LARGE Then
        argvVal = PdhVbGetDoubleCounterValue(vmlHCounter, vlStatus)

        If PdhVbIsGoodStatus(vlStatus) = 0 Then
            argvVal = 0: Exit Function
        End If

    Else '整数値の場合

        If PdhGetFormattedCounterValue(vmlHCounter, _
                                       PDH_FMT_LONG, _
                                       ByVal 0, _
                                       vtFmtVal) <> 0 Then
            argvVal = 0: Exit Function
        Else
            'PDH_FMT_COUNTERVALUEのCStatusメンバが有効な値と判断した時
            If (vtFmtVal.CStatus = PDH_CSTATUS_NEW_DATA) Or _
               (vtFmtVal.CStatus = PDH_CSTATUS_VALID_DATA) Then
                argvVal = vtFmtVal.longValue
            Else
                argvVal = 0: Exit Function
            End If
        End If
    End If

    GetCounterVal = True
  
End Function

VB/VBAの場合は一部PdhVb系APIを使います。なぜVB用にAPIが作られたかよくわかりませんが。引数など簡略化されていてお手軽に使えます。

以上でクラスの実装ができましたので CPerfMoniオブジェクトを使ってモニタします。標準モジュールに以下を記述して実行すると１秒間隔でアクティブシートにパフォーマンスデータが表示されます。例ではプロセッサの非アイドルプロセスの実行時間の割合をモニタしています。

Option Explicit

Public Sub DspPerformanceData()
    Static voObj     As CPerfMoni
    Dim vdVal        As Double
    Static i         As Long
     Const clCOUNT   As Long = 20 'データ収集回数

    If i < 1 Then
        Set voObj = New CPerfMoni
        'モニタ対象Counter
        If Not voObj.AddCounter("Processor", "% Processor Time", "_Total") Then Exit Sub
    ElseIf i >= clCOUNT Then
        Set voObj = Nothing: i = 0
        Exit Sub
    End If

    If voObj.GetCounterVal(vdVal) Then
        ActiveSheet.Cells(i + 1, 1).Value = i
        ActiveSheet.Cells(i + 1, 2).Value = vdVal
    End If

    Application.OnTime EarliestTime:=Now + TimeValue("00:00:01"), _
                       Procedure:="DspPerformanceData"
    i = i + 1

End Sub

参考文献　： PDH Visual Basic から API を使用してパフォーマンスデータの収集