Binaryworld - EnumRegistryValuesEx - Get all values under a registry key, with relat ... [ VB -> Windows ]

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 RegCloseKey Lib "advapi32.dll" (ByVal hKey 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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _
  Any, source As Any, ByVal numBytes As Long)
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
  lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, _
  lpData As Any, lpcbData As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
  (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
  ByVal cbName As Long) As Long

Const KEY_READ = &H20019 ' ((READ_CONTROL Or KEY_QUERY_VALUE Or
             ' KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not
             ' SYNCHRONIZE))
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234

'Enumerate values under a given registry key.
'Returns a collection, where each element of the collection is a 3-element array
'of Variants: element(0) is the value name, element(1) is the value's value,
' element(2) is the type of data type

Function EnumRegistryValuesEx(ByVal hKey As Long, ByVal KeyName As String) As _
  Collection
  Dim handle As Long
  Dim index As Long
  Dim valueType As Long
  Dim name As String
  Dim nameLen As Long
  Dim resLong As Long
  Dim resString As String
  Dim dataLen As Long
  Dim valueInfo(0 To 2) As Variant
  Dim retVal As Long

  ' initialize the result
  Set EnumRegistryValuesEx = New Collection

  ' Open the key, exit if not found.
  If Len(KeyName) Then
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
    ' in all cases, subsequent functions use hKey
    hKey = handle
  End If

  Do
    ' this is the max length for a key name
    nameLen = 260
    name = Space$(nameLen)
    ' prepare the receiving buffer for the value
    dataLen = 4096
    ReDim resBinary(0 To dataLen - 1) As Byte

    ' read the value's name and data
    ' exit the loop if not found
    retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, valueType, _
      resBinary(0), dataLen)

    ' enlarge the buffer if you need more space
    If retVal = ERROR_MORE_DATA Then
      ReDim resBinary(0 To dataLen - 1) As Byte
      retVal = RegEnumValue(hKey, index, name, nameLen, ByVal 0&, _
        valueType, resBinary(0), dataLen)
    End If
    ' exit the loop if any other error (typically, no more values)
    If retVal Then Exit Do

    ' retrieve the value's name
    valueInfo(0) = Left$(name, nameLen)

    ' return a value corresponding to the value type
    Select Case valueType
      Case REG_DWORD
        CopyMemory resLong, resBinary(0), 4
        valueInfo(1) = resLong
        valueInfo(2) = vbLong
      Case REG_SZ, REG_EXPAND_SZ
        ' copy everything but the trailing null char
        resString = Space$(dataLen - 1)
        CopyMemory ByVal resString, resBinary(0), dataLen - 1
        valueInfo(1) = resString
        valueInfo(2) = vbString
      Case REG_BINARY
        ' shrink the buffer if necessary
        If dataLen < UBound(resBinary) + 1 Then
          ReDim Preserve resBinary(0 To dataLen - 1) As Byte
        End If
        valueInfo(1) = resBinary()
        valueInfo(2) = vbArray + vbByte
      Case REG_MULTI_SZ
        ' copy everything but the 2 trailing null chars
        resString = Space$(dataLen - 2)
        CopyMemory ByVal resString, resBinary(0), dataLen - 2
        valueInfo(1) = resString
        valueInfo(2) = vbString
      Case Else
        ' Unsupported value type - do nothing
    End Select

    ' add the array to the result collection
    ' the element's key is the value's name
    EnumRegistryValuesEx.Add valueInfo, valueInfo(0)

    index = index + 1
  Loop

  ' Close the key, if it was actually opened
  If handle Then RegCloseKey handle

End Function