GetRegValue

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

' Read a Registry value
'
' Use KeyName = "" for the default value
' If the value isn't there, it returns the DefaultValue
' argument, or Empty if the argument has been omitted
'
' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ
' REG_MULTI_SZ values are returned as a null-delimited stream of strings
' (VB6 users can use SPlit to convert to an array of string)

Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
    ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
    Dim handle As Long
    Dim resLong As Long
    Dim resString As String
    Dim resBinary() As Byte
    Dim length As Long
    Dim retVal As Long
    Dim valueType As Long
    
    ' Prepare the default result
    GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
    
    ' Open the key, exit if not found.
    If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
        Exit Function
    End If
    
    ' prepare a 1K receiving resBinary
    length = 1024
    ReDim resBinary(0 To length - 1) As Byte
    
    ' read the registry key
    retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
        length)
    ' if resBinary was too small, try again
    If retVal = ERROR_MORE_DATA Then
        ' enlarge the resBinary, and read the value again
        ReDim resBinary(0 To length - 1) As Byte
        retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
            length)
    End If
    
    ' return a value corresponding to the value type
    Select Case valueType
        Case REG_DWORD
            CopyMemory resLong, resBinary(0), 4
            GetRegistryValue = resLong
        Case REG_SZ, REG_EXPAND_SZ
            ' copy everything but the trailing null char
            resString = Space$(length - 1)
            CopyMemory ByVal resString, resBinary(0), length - 1
            GetRegistryValue = resString
        Case REG_BINARY
            ' resize the result resBinary
            If length <> UBound(resBinary) + 1 Then
                ReDim Preserve resBinary(0 To length - 1) As Byte
            End If
            GetRegistryValue = resBinary()
        Case REG_MULTI_SZ
            ' copy everything but the 2 trailing null chars
            resString = Space$(length - 2)
            CopyMemory ByVal resString, resBinary(0), length - 2
            GetRegistryValue = resString
        Case Else
            RegCloseKey handle
            Err.Raise 1001, , "Unsupported value type"
    End Select
    
    ' close the registry key
    RegCloseKey handle
End Function

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)

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

' Read a Registry value

'

' Use KeyName = "" for the default value

' If the value isn't there, it returns the DefaultValue

' argument, or Empty if the argument has been omitted

'

' Supports DWORD, REG_SZ, REG_EXPAND_SZ, REG_BINARY and REG_MULTI_SZ

' REG_MULTI_SZ values are returned as a null-delimited stream of strings

' (VB6 users can use SPlit to convert to an array of string)

Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long

' Prepare the default result

GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)

' Open the key, exit if not found.

If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If

' prepare a 1K receiving resBinary

length = 1024
ReDim resBinary(0 To length - 1) As Byte

' read the registry key

retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
' if resBinary was too small, try again

If retVal = ERROR_MORE_DATA Then
' enlarge the resBinary, and read the value again

ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If

' return a value corresponding to the value type

Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
' copy everything but the trailing null char

resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
' resize the result resBinary

If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
' copy everything but the 2 trailing null chars

resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
RegCloseKey handle
Err.Raise 1001, , "Unsupported value type"
End Select

' close the registry key

RegCloseKey handle
End Function