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
'Object列挙
Private Declare Function PdhEnumObjects Lib "pdh" Alias "PdhEnumObjectsA" _
(ByVal lpDataSource As String, _
ByVal lpMachineName As String, _
ByVal lpObjectList As String, _
dwBufferSize As Long, _
ByVal dwDetailLevel As Long, _
ByVal bRefresh As Boolean) As Long
'Counter/Instance列挙
Private Declare Function PdhEnumObjectItems Lib "pdh" Alias "PdhEnumObjectItemsA" _
(ByVal lpDataSource As String, _
ByVal lpMachineName As String, _
ByVal lpObjectName As String, _
ByVal lpCounterList As String, _
dwCounterListLength As Long, _
ByVal lpInstanceList As String, _
dwInstanceListLength As Long, _
ByVal dwDatailLevel As Long, _
ByVal dwFlags As Long) As Long
'リスト取得レベル定数
Private Const PERF_DETAIL_NOVICE As Long = 100
Private Const PERF_DETAIL_ADVANCED As Long = 200
Private Const PERF_DETAIL_EXPERT As Long = 300
Private Const PERF_DETAIL_WIZARD As Long = 400
'問合せに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
'カウンタ情報格納用構造体
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
buf(3) As Byte 'Padding?
szExplainText As Long
DataBuffer As Long
End Type
'文字列コピー
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
(ByVal lpString1 As String, _
ByVal lpString2 As Long) As Long
'メモリブロックコピー
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
'----------------------------------------------------------------------------
'各Performance Object情報格納用
Public Type OBJECT_SERIES
Object As String 'Object名
ObjectHelp As String 'Object説明
Instances() As String 'Object内のInstance名の配列
Counters() As String 'Object内のCounter名の配列
CounterHelps() As String 'Object内のCounterの説明の配列
End Type
'Object/Counter/Instance名とその説明の一覧表示
Public Sub DspPerformanceList()
Dim voObjArray() As OBJECT_SERIES
Dim vlStartRow As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim vlInstCnt As Long
Dim vlCntrCnt As Long
'パフォーマンス各名称取得
GPrcGetPdhObjectList voObjArray
vlStartRow = 2
For i = 0 To UBound(voObjArray)
'オブジェクト名出力
With ActiveSheet
.Cells(vlStartRow, 1).Value = voObjArray(i).Object
.Cells(vlStartRow, 3).Value = voObjArray(i).ObjectHelp
End With
'インスタンス名出力
For j = 0 To UBound(voObjArray(i).Instances)
ActiveSheet.Cells(vlStartRow + j + 1, 2).Value = voObjArray(i).Instances(j)
Next j
'カウンタ名出力
For k = 0 To UBound(voObjArray(i).Counters)
With ActiveSheet
.Cells(vlStartRow + k + 1, 3).Value = voObjArray(i).Counters(k)
.Cells(vlStartRow + k + 1, 4).Value = voObjArray(i).CounterHelps(k)
End With
Next k
vlInstCnt = UBound(voObjArray(i).Instances) + 1
vlCntrCnt = UBound(voObjArray(i).Counters) + 1
vlStartRow = vlStartRow + IIf(vlInstCnt > vlCntrCnt, vlInstCnt, vlCntrCnt) + 2
Next i
End Sub
'Object/Counter/Instanceとその説明列挙
'第一引数 : 未初期化のOBJECT_SERIES型の配列
'仕様 : 未初期化のOBJECT_SERIES構造体を渡すとパフォーマンスオブジェクトと同数の
' OBJECT_SERIESインスタンスが返却される。各OBJECT_SERIESインスタンス内に
' そのオブジェクトのカウンタ／インスタンス情報が格納される
Public Sub GPrcGetPdhObjectList(argoObjSeries() As OBJECT_SERIES)
Dim vlHQuery As Long '問合せへのハンドル
Dim vlSize As Long 'Object文字列リストのサイズ
Dim vsObjectList As String 'Object文字列(MULTI_SZ形式)
Dim vlStart As Long '文字列切出し時の各Object名の最初の文字位置
Dim vvEnd As Variant '文字列切出し時の各Object名のNULL終端文字の位置
'問合せ初期化
If PdhOpenQuery(vlHQuery) <> 0 Then Exit Sub
'Objectリストサイズ取得
PdhEnumObjects vbNullString, vbNullString, vbNullString, _
vlSize, PERF_DETAIL_EXPERT, True
'Object名リスト格納サイズ確保
vsObjectList = Space(vlSize)
'Object名リスト取得
If PdhEnumObjects(vbNullString, vbNullString, vsObjectList, _
vlSize, PERF_DETAIL_EXPERT, False) <> 0 Then Exit Sub
'vsObjectListから各Object名切出し
vlStart = 1
Do
'最も近いNULL終端文字の位置検索
vvEnd = InStr(vlStart, vsObjectList, Chr(0), vbBinaryCompare)
If vvEnd = 0 Or IsNull(vvEnd) Then Exit Do
'結果を受取るargoObjSeriesメモリ領域再確保
If vlStart = 1 Then
ReDim argoObjSeries(0)
Else
ReDim Preserve argoObjSeries(UBound(argoObjSeries) + 1)
End If
argoObjSeries(UBound(argoObjSeries)).Object = _
Mid(vsObjectList, vlStart, vvEnd - vlStart)
'Counter/Instance取得
FnGetPdhObjectItemList argoObjSeries(UBound(argoObjSeries)), vlHQuery
'MULTI_SZ形式でNULL終端文字が続いたら終了
If Asc(Mid(vsObjectList, vvEnd + 1, 1)) = 0 Then Exit Do
vlStart = vvEnd + 1
Loop
PdhCloseQuery vlHQuery
End Sub
'カウンタ名／インスタンス名取得
'第一引数 : ObjectメンバにObject名が入ったOBJECT_SERIES型のインスタンス
'第二引数 : 問合せへのハンドル
'仕様 : 第一引数のObjectメンバのObject名からCounter名,Instance名を検索し
' 第一引数のargoObjeSeriesの該当メンバに情報を格納
Private Function FnGetPdhObjectItemList(argoObjSeries As OBJECT_SERIES, _
arglHQuery As Long) As Boolean
Dim vlCounterSize As Long 'Counter文字列リストサイズ
Dim vlInstanceSize As Long 'Instance文字列リストサイズ
Dim vsCounterList As String 'Counter文字列リスト(MULTI_SZ形式)
Dim vsInstanceList As String 'Instance文字列リスト(MULTI_SZ形式)
Dim vsInstForExplain As String 'PdhAddCounter用Instance名
Dim vsExplain As String 'Counter説明文字列
Dim vlStart As Long '各Counter/Instance名の開始位置
Dim vvEnd As Variant '各Counter/Instance名のNULL終端文字位置
Dim vyFailFlg As Boolean '切出し失敗フラグ
'Counter/Instanceの文字列リストサイズ取得
vlCounterSize = 0: vlInstanceSize = 0
PdhEnumObjectItems vbNullString, vbNullString, argoObjSeries.Object, _
vbNullString, vlCounterSize, _
vbNullString, vlInstanceSize, _
PERF_DETAIL_EXPERT, 0
'Counter/Instance文字列リスト取得
vsCounterList = Space(vlCounterSize): vsInstanceList = Space(vlInstanceSize)
If PdhEnumObjectItems(vbNullString, vbNullString, argoObjSeries.Object, _
vsCounterList, vlCounterSize, _
vsInstanceList, vlInstanceSize, _
PERF_DETAIL_EXPERT, 0) <> 0 Then Exit Function
'インスタンス列挙
If (vlInstanceSize > 2) Then
vlStart = 1
Do
'最も近いNULL終端文字検索
vvEnd = InStr(vlStart, vsInstanceList, Chr(0), vbBinaryCompare)
If vvEnd = 0 Or IsNull(vvEnd) Then
vyFailFlg = True: Exit Do
End If
'結果を受取るargoObjSeries.Instances領域再確保
If vlStart = 1 Then
ReDim argoObjSeries.Instances(0)
Else
ReDim Preserve argoObjSeries.Instances(UBound(argoObjSeries.Instances) + 1)
End If
'結果格納
argoObjSeries.Instances(UBound(argoObjSeries.Instances)) = _
Mid(vsInstanceList, vlStart, vvEnd - vlStart)
'PdhAddCounter実行用Instance名取得
If vlStart = 1 Then
vsInstForExplain = Mid(vsInstanceList, vlStart, vvEnd - vlStart)
End If
'NULL終端文字が続いたら終了
If Asc(Mid(vsInstanceList, vvEnd + 1, 1)) = 0 Then Exit Do
vlStart = vvEnd + 1
Loop
Else
ReDim argoObjSeries.Instances(0)
End If
'カウンタ列挙
vlStart = 1
Do
'最も近いNULL終端文字検索
vvEnd = InStr(vlStart, vsCounterList, Chr(0), vbBinaryCompare)
If vvEnd = 0 Or IsNull(vvEnd) Then
vyFailFlg = True: Exit Do
End If
'カウンタの説明取得
FnGetPdhCounterExplain argoObjSeries.Object, _
Mid(vsCounterList, vlStart, vvEnd - vlStart), _
vsInstForExplain, _
arglHQuery, _
vsExplain
'結果を受取るargoObjSeries.Counters領域再確保
If vlStart = 1 Then
ReDim argoObjSeries.Counters(0)
ReDim argoObjSeries.CounterHelps(0)
Else
ReDim Preserve argoObjSeries.Counters(UBound(argoObjSeries.Counters) + 1)
ReDim Preserve _
argoObjSeries.CounterHelps(UBound(argoObjSeries.CounterHelps) + 1)
End If
'結果格納
argoObjSeries.Counters(UBound(argoObjSeries.Counters)) = _
Mid(vsCounterList, vlStart, vvEnd - vlStart)
argoObjSeries.CounterHelps(UBound(argoObjSeries.CounterHelps)) = vsExplain
'NULL終端文字が続けば終了
If Asc(Mid(vsCounterList, vvEnd + 1, 1)) = 0 Then Exit Do
vlStart = vvEnd + 1
Loop
FnGetPdhObjectItemList = IIf(vyFailFlg, False, True)
End Function
'カウンタの説明取得
'第一引数 : Object名
'第二引数 : Counter名
'第三引数 : Instance名
'第四引数 : 問合せへのハンドル
'第五引数 : Counterの説明を受取るバッファ
'仕様 : 第一〜第三引数に対応するCounterの説明文字列を第五引数に格納
Private Function FnGetPdhCounterExplain(argsObjectName As String, _
argsCounterName As String, _
argsInstanceName As String, _
arglHQuery As Long, _
argsExplain As String) As Boolean
Dim vsCounterPath As String 'Counterパス
Dim vlCounterInfoSize As Long 'PDH_COUNTER_INFO必要サイズ
Dim vlHCounter As Long 'カウンタへのハンドル
Dim vcBuf() As Byte 'PDH_COUNTER_INFOのバイトシーケンス情報
Dim vtCounterInfo As PDH_COUNTER_INFO 'PDH_COUNTER_INFO構造体
'カウンタパス作成
vsCounterPath = "\" & argsObjectName
If Len(argsInstanceName) Then
vsCounterPath = vsCounterPath & "(" & argsInstanceName & ")"
End If
vsCounterPath = vsCounterPath & "\" & argsCounterName
'問合せにカウンタ追加
If PdhAddCounter(arglHQuery, vsCounterPath, vlHCounter) <> 0 Then
argsExplain = "": Exit Function
End If
'カウンタ情報(PDH_COUNTER_INFO構造体)の必要サイズ取得
PdhGetCounterInfo vlHCounter, True, vlCounterInfoSize, ByVal 0
'カウンタ情報必要サイズ取得
ReDim vcBuf(vlCounterInfoSize)
'カウンタ情報取得
If PdhGetCounterInfo(vlHCounter, True, vlCounterInfoSize, vcBuf(0)) <> 0 Then
argsExplain = "": Exit Function
End If
'PDH_COUNTER_INFO構造体にバイトシーケンスをコピー
CopyMemory vtCounterInfo, vcBuf(0), Len(vtCounterInfo)
'結果を第五引数に渡す
argsExplain = Space(vlCounterInfoSize)
If lstrcpy(argsExplain, vtCounterInfo.szExplainText) = 0 Then
argsExplain = "": Exit Function
End If
FnGetPdhCounterExplain = True
End Function
|