【VBA】レジストリのサブキーと値の列挙

VBAでレジストリのサブキーと値を列挙する方法を紹介します。
やり方が3種類あります。

• reg queryコマンドを使う
• WMIを使う
• Windows APIを使う

reg queryコマンドを使う

レジストリアクセス用のreg queryコマンドをWshShellオブジェクトから呼び出す方法です。Exe()の結果を標準出力から取り出します。

Option Explicit

Sub Sample1()
    Dim Command As String
    Dim Shell As Object
    Dim Exec As Object

    ' 実行するコマンド
    Command = "reg query ""HKEY_CURRENT_USER\Control Panel\Desktop"""
    
    Set Shell = CreateObject("WScript.Shell")
    
    ' Exec()でコマンド実行
    Set Exec = Shell.Exec(Command)
    
    Do While Not Exec.StdOut.AtEndOfStream
        '実行結果を1行ずつ取り出す
        Debug.Print Exec.StdOut.ReadLine
    Loop
    
    Set Shell = Nothing
End Sub

WMIを使う

WMI StdRegProvクラスのEnumKey()とEnumValues()を使う方法です。

Option Explicit

'WMI用定数
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005

Sub Sample2()
    Dim WMI As Object
    Dim SubKeys As Variant
    Dim ValueNames As Variant
    Dim ValueTypes As Variant
    Dim i As Long
    
    'WMIサービスの取得
    Set WMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
    
    ' EnumKey()でサブキー一覧を取得
    If WMI.EnumKey(HKEY_CURRENT_USER, "Control Panel\Desktop", SubKeys) = 0 Then
        If Not IsNull(SubKeys) Then
            'サブキーを列挙
            For i = LBound(SubKeys) To UBound(SubKeys)
                Debug.Print SubKeys(i)
            Next i
        End If
    End If

    ' EnumValues()で値一覧を取得
    If WMI.EnumValues(HKEY_CURRENT_USER, "Control Panel\Desktop", ValueNames, ValueTypes) = 0 Then
        If Not IsNull(ValueNames) Then
            '値を列挙
            For i = LBound(ValueNames) To UBound(ValueNames)
                Debug.Print ValueNames(i), ValueTypes(i)
            Next i
        End If
    End If
    
    Set WMI = Nothing
End Sub

Windows APIを使う

Windows APIのRegEnumKeyEx()とRegEnumValue()を使う方法です。

Option Explicit

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Const READ_CONTROL = &H20000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_READ = (READ_CONTROL)

Const ERROR_SUCCESS = 0&

Const ERROR_NO_MORE_ITEMS = 259&

Const HKEY_CURRENT_USER = &H80000001

Const KEY_QUERY_VALUE = &H1
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))

Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
Declare PtrSafe Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As LongPtr, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Declare PtrSafe Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As LongPtr, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As LongPtr, lpType As Long, lpData As Byte, lpcbData As Long) As Long


Sub Sample3()
    Const BUFFER_SIZE = 256 'バッファサイズ
    
    Dim hKey As LongPtr
    Dim Result As Long
    Dim ft As FILETIME
    Dim Buffer As String * BUFFER_SIZE
    Dim BufferSize As Long
    Dim s As String
    Dim lpType As Long
    Dim Index As Long

    'レジストリキーのハンドルを取得
    Result = RegOpenKeyEx(HKEY_CURRENT_USER, "Control Panel\Desktop", 0, KEY_READ, hKey)
    If Result <> ERROR_SUCCESS Then
        Exit Sub
    End If

    Index = 0 'サブキーのインデックス
    Do
        'RegEnumKey()でサブキーの列挙
        Buffer = String(BUFFER_SIZE, vbNullChar)
        BufferSize = BUFFER_SIZE
        With ft
            .dwHighDateTime = 0
            .dwLowDateTime = 0
        End With
        Result = RegEnumKeyEx(hKey, Index, Buffer, BufferSize, 0, vbNullString, ByVal 0, ft)
        
        If Result = ERROR_SUCCESS Then '成功
            'Windows APIから文字列を取得した場合はvbNullCharより右の文字列を削除する
            s = Left(Buffer, InStr(Buffer, vbNullChar) - 1)
            Debug.Print s
        ElseIf Result = ERROR_NO_MORE_ITEMS Then 'これ以上のサブキーはなし
            Exit Do
        Else '失敗
            'ハンドルを閉じる
            RegCloseKey hKey
            Exit Sub
        End If

        Index = Index + 1 'インデックスをインクリメント
    Loop
       
    Index = 0 '値のインデックス
    Do
        'RegEnumValue()で値の列挙
        Buffer = String(BUFFER_SIZE, vbNullChar)
        BufferSize = BUFFER_SIZE
        lpType = 0
        Result = RegEnumValue(hKey, Index, Buffer, BufferSize, 0, lpType, ByVal 0, ByVal 0)
        If Result = ERROR_SUCCESS Then '成功
            'Windows APIから文字列を取得した場合はvbNullCharより右の文字列を削除する
            s = Left(Buffer, InStr(Buffer, vbNullChar) - 1)
            Debug.Print s, lpType
        ElseIf Result = ERROR_NO_MORE_ITEMS Then 'これ以上の値はなし
            Exit Do
        Else '失敗
            'ハンドルを閉じる
            RegCloseKey hKey
            Exit Sub
        End If

        Index = Index + 1 'インデックスをインクリメント
    Loop

    'ハンドルを閉じる
    RegCloseKey hKey
End Sub