Option Explicit

'レジストリキーOpen
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, _
     ByVal lpSubKey As String, _
     ByVal ulOptions As Long, _
     ByVal samDesired As Long, _
     phkResult As Long) As Long

'対象レジストリキーのデータ取得
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, _
     ByVal lpValueName As String, _
     ByVal lpReserved As Long, _
     lpType As Long, _
     lpData As Any, _
     lpcbData As Long) As Long

'レジストリキーClose
Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long

'レジストリキー内の情報取得(キー内の最大の文字数取得)
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
    (ByVal hKey As Long, _
     ByVal lpClass As String, _
     lpcbClass As Long, _
     ByVal lpReserved As Long, _
     lpcSubKeys As Long, _
     lpcbMaxSubKeyLen As Long, _
     lpcbMaxClassLen As Long, _
     lpcValues As Long, lpcbMaxValueNameLen As Long, _
     lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, _
     ByVal lpftLastWriteTime As Long) As Long   'lpftLastWriteTimeはFILETIME型だが
                                                '使用しないのでLong

Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const SYNCHRONIZE = &H100000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ _
                        Or KEY_QUERY_VALUE _
                        Or KEY_ENUMERATE_SUB_KEYS _
                        Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const ERROR_MORE_DATA = 234 ' dderror
Private Const HKEY_PERFORMANCE_DATA = &H80000004

'----------------------------------------------------------------------------------------
'Unicode文字列コピー
Private Declare Function lstrcpyW Lib "kernel32" _
    (ByVal lpString1 As String, lpString2 As Byte) As Long  'Unicode版  コピー引数の型注意

'メモリブロックコピー
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
     Source As Any, _
     ByVal Length As Long)

'64ビット符号付Interger
Private Type LARGE_INTEGER
    lowpart  As Long
    highpart As Long
End Type

'日付／時間表示用
Private Type SYSTEMTIME
    wYear         As Integer
    wMonth        As Integer
    wDayOfWeek    As Integer
    wDay          As Integer
    wHour         As Integer
    wMinute       As Integer
    wSecond       As Integer
    wMilliseconds As Integer
End Type

'PERF_DATA_BLOCK構造体
Private Type PERF_DATA_BLOCK
    Signature        As String * 8     'Unicodeのため4ではなく8 
    LittleEndian     As Long
    Version          As Long
    Revision         As Long
    TotalByteLength  As Long
    HeaderLength     As Long
    NumObjectTypes   As Long
    DefaultObject    As Long
    SYSTEMTIME       As SYSTEMTIME
    buf(1)           As Byte    'Padding? 
    PerfTime         As LARGE_INTEGER
    PerfFreq         As LARGE_INTEGER
    PerTime100nSec   As LARGE_INTEGER
    SystemNameLength As Long
    SystemNameOffset As Long
End Type

'PERF_OBJECT_TYPE構造体
Private Type PERF_OBJECT_TYPE
    TotalByteLength      As Long
    DefinitionLength     As Long
    HeaderLength         As Long
    ObjectNameTitleIndex As Long
    ObjectNameTitle      As Long    'String
    ObjectHelpTitleIndex As Long
    ObjectHelpTitle      As Long    'String
    DetailLevel          As Long
    NumCounters          As Long
    DefaultCounter       As Long
    NumInstances         As Long
    CodePage             As Long
    PerfTime             As LARGE_INTEGER
    PerfFreq             As LARGE_INTEGER
End Type

'PERF_COUNTER_DEFINITION構造体
Private Type PERF_COUNTER_DEFINITION
    ByteLength            As Long
    CounterNameTitleIndex As Long
    CounterNameTitle      As Long   'String
    CounterHelpTitleIndex As Long
    CounterHelpTitle      As Long   'String
    DefaultScale          As Long
    DetailLevel           As Long
    CounterType           As Long
    CounterSize           As Long
    CounterOffset         As Long
End Type

'PERF_INSTANCE_DEFINITION構造体
Private Type PERF_INSTANCE_DEFINITION
    ByteLength             As Long
    ParentObjectTitleIndex As Long
    ParentObjectInstance   As Long
    UniqueID               As Long
    NameOffset             As Long
    NameLength             As Long
End Type

'PERF_COUNTER_BLOCK構造体
Private Type PERF_COUNTER_BLOCK
    ByteLength As Long
End Type

'------------------------------------------------------------------
'各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

'//////////////////////////////////////////////////////////////////////////  
'WorkSheetにパフォーマンスオブジェクトデータ出力
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

    'パフォーマンス各名称取得
    GPrcGetPerfDataFromRegistry 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 GPrcGetPerfDataFromRegistry(argoObjSeries() As OBJECT_SERIES)
    Dim vcPerfDataBlock()    As Byte     'HKEY_PARFORMANCE_DATAで取得するデータブロック
    Dim vlPerfDataBlockSize  As Long     'データブロックサイズ
    Dim vlTempSize           As Long     'データブロック一時サイズ
    Dim vtPerfDataBlock      As PERF_DATA_BLOCK  'PERF_DATA_BLOCK構造体
    Dim vtPerfObject         As PERF_OBJECT_TYPE 'PERF_OBJECT_TYPE構造体
    Dim vlCurObjPoint        As Long     'vcPerfDataBlockでの現在のObjectの
                                         'バイト位置
    Dim vtPerfInstance       As PERF_INSTANCE_DEFINITION 'PERF_INSTANCE_DEFINITION構造体
    Dim vlCurInstPoint       As Long     'vcPerfDataBlockでの現在のInstanceのバイト位置
    Dim vtPerfCntrBlock      As PERF_COUNTER_BLOCK  'PERF_COUNTER_BLOCK構造体
    Dim vlInstNamePoint      As Long     'Instanceの先頭からその名前が格納されている位置まで
                                         'のバイト位置
    Dim vsParentInstName     As String   '親Instance名
    Dim vsInstName           As String   'Instance名

    Dim vtPerfCounter        As PERF_COUNTER_DEFINITION 'PERF_COUNTER_DEFINITION構造体
    Dim vlCurCntrPoint       As Long     'vcPerfDataBlockでの現在のCounterのバイト位置

    Dim i                    As Long
    Dim j                    As Long
    Dim k                    As Long

    Dim vsStringArray()      As String   'SOFTWARE\Microsoft\Windows NT\CurrentVersion\
                                         'Perflib\011キーObject/Counter/Instance名とIndex
    Dim vsExplainArray()     As String   'SOFTWARE\Microsoft\Windows NT\CurrentVersion\
                                         'Perflib\011キーObject/Counterの説明とIndex
                                         
    vlPerfDataBlockSize = 204800: vlTempSize = 204800
    ReDim vcPerfDataBlock(204800 - 1)

    'HKEY_PERFORMANCE_DATAキーより vcPerfDataBlockにパフォーマンスデータ取得
    Do While (RegQueryValueEx(HKEY_PERFORMANCE_DATA, _
                             "Global", 0, ByVal 0, _
                             vcPerfDataBlock(0), vlTempSize) = ERROR_MORE_DATA)

        vlPerfDataBlockSize = vlPerfDataBlockSize + 1024: vlTempSize = vlPerfDataBlockSize
        ReDim vcPerfDataBlock(vlPerfDataBlockSize - 1)
    Loop

    'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011キーよりデータ取得
    If Not FnGetRawDataFromRegistry(vsStringArray, False) Then Exit Sub

    'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011キーより説明取得
    If Not FnGetRawDataFromRegistry(vsExplainArray, True) Then Exit Sub

    'PERF_DATA_BLOCKインスタンス取得
    CopyMemory vtPerfDataBlock, vcPerfDataBlock(0), Len(vtPerfDataBlock)

    '結果出力用Object格納用配列確保
    ReDim argoObjSeries(vtPerfDataBlock.NumObjectTypes - 1)

    '最初のオブジェクト
    vlCurObjPoint = vtPerfDataBlock.HeaderLength
    CopyMemory vtPerfObject, vcPerfDataBlock(vlCurObjPoint), Len(vtPerfObject)

    'オブジェクト列挙
    For i = 0 To vtPerfDataBlock.NumObjectTypes - 1
        'OBJECT_SERIES構造体領域確保  
        ReDim argoObjSeries(i).Instances(IIf(vtPerfObject.NumInstances > 0, _
                                             vtPerfObject.NumInstances - 1, _
                                             0) _
                                        )
        ReDim argoObjSeries(i).Counters(vtPerfObject.NumCounters - 1)
        ReDim argoObjSeries(i).CounterHelps(vtPerfObject.NumCounters - 1)

        'Object名/説明出力
        argoObjSeries(i).Object = vsStringArray(vtPerfObject.ObjectNameTitleIndex)
        argoObjSeries(i).ObjectHelp = vsExplainArray(vtPerfObject.ObjectHelpTitleIndex)

        '現オブジェクトにInstanceがある時
        If vtPerfObject.NumInstances > 0 Then
            '最初のInstance
            vlCurInstPoint = vlCurObjPoint + vtPerfObject.DefinitionLength
            CopyMemory vtPerfInstance, vcPerfDataBlock(vlCurInstPoint), Len(vtPerfInstance)

            'インスタンス列挙
            For j = 0 To vtPerfObject.NumInstances - 1
                'Instance名取得(Unicode)
                vlInstNamePoint = vlCurInstPoint + vtPerfInstance.NameOffset
                vsInstName = Space(vtPerfInstance.NameLength)
                lstrcpyW vsInstName, vcPerfDataBlock(vlInstNamePoint)
                vsInstName = StrConv(vsInstName, vbFromUnicode)     'Unicode→ANSI
                'vsInstName = Left(vsInstName, _
                                   InStr(1, vsInstName, Chr(0), vbBinaryCompare) - 1)
                                            '最後のChr(0)文字の切取

                '親Instanceがある場合名前取得
                If vtPerfInstance.ParentObjectTitleIndex > 0 Then
                    vsParentInstName = FnGetParentInstanceName _    
                                                (vtPerfInstance.ParentObjectTitleIndex, _
                                                 vtPerfInstance.ParentObjectInstance, _
                                                 vcPerfDataBlock)
                    If vsParentInstName <> "" Then
                        vsParentInstName = vsParentInstName & "/"
                    End If

                    vsInstName = vsParentInstName & vsInstName
                End If

                'Instance名出力
                argoObjSeries(i).Instances(j) = vsInstName

                '次のインスタンス
                vlCurInstPoint = vlCurInstPoint + vtPerfInstance.ByteLength
                CopyMemory vtPerfCntrBlock, _
                           vcPerfDataBlock(vlCurInstPoint), _
                           Len(vtPerfCntrBlock)
                vlCurInstPoint = vlCurInstPoint + vtPerfCntrBlock.ByteLength
                CopyMemory vtPerfInstance, _
                           vcPerfDataBlock(vlCurInstPoint), _
                           Len(vtPerfInstance)
            Next j
        End If

        '最初のカウンタ
        vlCurCntrPoint = vlCurObjPoint + vtPerfObject.HeaderLength
        CopyMemory vtPerfCounter, vcPerfDataBlock(vlCurCntrPoint), Len(vtPerfCounter)

        'カウンタ列挙
        For k = 0 To vtPerfObject.NumCounters - 1
            'Counter名/説明の出力
            argoObjSeries(i).Counters(k) = _
                               vsStringArray(vtPerfCounter.CounterNameTitleIndex)
            argoObjSeries(i).CounterHelps(k) = _
                               vsExplainArray(vtPerfCounter.CounterHelpTitleIndex)

            '次のカウンタ
            vlCurCntrPoint = vlCurCntrPoint + vtPerfCounter.ByteLength
            CopyMemory vtPerfCounter, vcPerfDataBlock(vlCurCntrPoint), Len(vtPerfCounter)
        Next k

        '次のオブジェクト
        vlCurObjPoint = vlCurObjPoint + vtPerfObject.TotalByteLength
        CopyMemory vtPerfObject, vcPerfDataBlock(vlCurObjPoint), Len(vtPerfObject)
    Next i

    RegCloseKey HKEY_PERFORMANCE_DATA
End Sub

'親インスタンスの取得
'第一引数 : PERF_INSTANCE_DEFINITIONオブジェクト内で取得した
'           ParentObjectTitleIndexメンバ
'第二引数 : PERF_INSTANCE_DEFINITIONオブジェクト内で取得した
'           ParentObjectInstanceメンバ
'第三引数 : 親Instance名取得のためのデータブロック
'           (HKEY_PERFORMANCE_DATAをキーにしてRegQueryValueExで取得)
'戻値     : 親インスタンス名
'仕様 : 第三引数で指定したデータブロックからPERF_INSTANCE_DEFINITIONから
'       得た親インスタンスが属しているObjectのインデックスを第一引数に
'       Object内の検索対象のPERF_INSTANCE_DEFINITIONの位置を第二引数に
'       して親インスタンス名を返却する    
Private Function FnGetParentInstanceName(ByVal arglParentObjIdx As Long, _
                                         ByVal arglParentInstIdx As Long, _
                                         argcPerfDataBlock() As Byte) As String
    Dim vtPerfDataBlock  As PERF_DATA_BLOCK 'PERF_DATA_BLOCK構造体
    Dim vlCurObjPoint    As Long    'argcPerfDataBlock内での現在のObjectのバイト位置
    Dim vtPerfObject     As PERF_OBJECT_TYPE 'PERF_OBJECT_TYPE構造体
    Dim vlCurInstPoint   As Long    'argcPerfDataBlock内での現在のInstanceのバイト位置
    Dim vtPerfInstance   As PERF_INSTANCE_DEFINITION 'PERF_INSTANCE_DEFINITION構造体
    Dim vtCntrBlock      As PERF_COUNTER_BLOCK      'PERF_COUNTER_BLOCK構造体
    Dim i                As Long
    Dim j                As Long
    Dim vsResult         As String          '結果文字列

    'PERF_DATA_BLOCK取得
    CopyMemory vtPerfDataBlock, argcPerfDataBlock(0), Len(vtPerfDataBlock)

    '最初のObject
    vlCurObjPoint = vtPerfDataBlock.HeaderLength
    CopyMemory vtPerfObject, argcPerfDataBlock(vlCurObjPoint), Len(vtPerfObject)

    'Object検索
    For i = 0 To vtPerfDataBlock.NumObjectTypes - 1
        If vtPerfObject.ObjectNameTitleIndex = arglParentObjIdx Then Exit For

        '次のObject
        vlCurObjPoint = vlCurObjPoint + vtPerfObject.TotalByteLength
        CopyMemory vtPerfObject, argcPerfDataBlock(vlCurObjPoint), Len(vtPerfObject)
    Next i
    If i >= vtPerfDataBlock.NumObjectTypes Then
        FnGetParentInstanceName = "": Exit Function
    End If

    '最初のInstance
    vlCurInstPoint = vlCurObjPoint + vtPerfObject.DefinitionLength
    CopyMemory vtPerfInstance, argcPerfDataBlock(vlCurInstPoint), Len(vtPerfInstance)

    'Instance検索
    For j = 0 To vtPerfObject.NumInstances - 1
        If j = arglParentInstIdx Then Exit For

        '次のInstance
        vlCurInstPoint = vlCurInstPoint + vtPerfInstance.ByteLength
        CopyMemory vtCntrBlock, argcPerfDataBlock(vlCurInstPoint), Len(vtCntrBlock)
        vlCurInstPoint = vlCurInstPoint + vtCntrBlock.ByteLength
        CopyMemory vtPerfInstance, argcPerfDataBlock(vlCurInstPoint), Len(vtPerfInstance)
    Next j
    If j >= vtPerfObject.NumInstances Then
        FnGetParentInstanceName = "": Exit Function
    End If

    'vtPerfInstaceからインスタンス名取得
    vsResult = Space(vtPerfInstance.NameLength)
    lstrcpyW vsResult, argcPerfDataBlock(vlCurInstPoint + vtPerfInstance.NameOffset)
    vsResult = StrConv(vsResult, vbFromUnicode)     'Unicode→ANSI

    'vsResultの最後のChr(0)を切取る
    FnGetParentInstanceName = Left(vsResult, _
                                   InStr(1, vsResult, Chr(0), vbBinaryCompare) - 1)
End Function

'<Registry使用> RegistryよりObject/Counter又は説明データの取得
'第一引数 :SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011
'          キーから結果を受取る文字列の配列
'第二引数 :オブジェクト名/カウンタ名を第一引数に受取る時はTrue
'戻値     :第一引数にデータ取得成功時True
'仕様 Object名/Counter名のインデックスを第一引数の配列の要素番号に
'     して対応する名称／説明を第一引数に格納する
Private Function FnGetRawDataFromRegistry(argsStringArray() As String, _
                                          Optional argyHelp As Boolean = False) As Boolean
    Dim vlHPerflib  As Long
    Dim vlLastIdx   As Long
    Dim vlMaxLen    As Long
    Dim vsRawString As String
    Dim vlStart     As Long
    Dim vvEnd       As Variant
    Dim i           As Long
    Dim vlIdx       As Long

    'Counterと説明の最後のIndex取得のために
    'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib
    'キーを開く
    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
                    "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib", _
                    0, KEY_READ, _
                    vlHPerflib) <> 0 Then
        Exit Function
    End If

    '最後のインデックスの取得
    If RegQueryValueEx(vlHPerflib, _
                       IIf(argyHelp, "Last Help", "Last Counter"), _
                       0, ByVal 0, vlLastIdx, LenB(vlLastIdx)) <> 0 Then
        RegCloseKey vlHPerflib: Exit Function
    End If
    RegCloseKey vlHPerflib

    'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011キーの
    'CounterまたはHelpエントリのデータ取得のためキーをOpen
    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, _
                    "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011", _
                    0, KEY_READ, _
                    vlHPerflib) <> 0 Then
        Exit Function
    End If

    'SOFTWARE\Microsoft\Windows NT\CurrentVersion\Perflib\011キーの
    '内で最大の文字列の長さのバイト数を取得
    If RegQueryInfoKey(vlHPerflib, 0, 0, 0, 0, 0, 0, 0, 0, vlMaxLen, 0, 0) <> 0 Then
        RegCloseKey vlHPerflib: Exit Function
    End If

    '取得領域確保
    vsRawString = Space(vlMaxLen)

    If RegQueryValueEx(vlHPerflib, _
                       IIf(argyHelp, "Help", "Counter"), _
                       0, ByVal 0, _
                       ByVal vsRawString, vlMaxLen) <> 0 Then
        RegCloseKey vlHPerflib: Exit Function
    End If

    '最後のインデックス分の文字列の配列確保
    ReDim argsStringArray(vlLastIdx)

    'MULTI_SZ形式のvsRawStringをIndexとデータ部に分けてargsStringArrayに格納
    vlStart = 1
    Do
        For i = 0 To 1
            vvEnd = InStr(vlStart, vsRawString, Chr(0), vbBinaryCompare)
            If vvEnd = 0 Or IsNull(vvEnd) Then Exit Do

            If i = 0 Then vlIdx = CLng(Mid(vsRawString, vlStart, vvEnd - vlStart))
            If i = 1 Then
                argsStringArray(vlIdx) = Mid(vsRawString, vlStart, vvEnd - vlStart)
            End If

            vlStart = vvEnd + 1
        Next i

        If Asc(Mid(vsRawString, vvEnd + 1, 1)) = 0 Then Exit Do
    Loop

    FnGetRawDataFromRegistry = True
End Function