Attribute VB_Name = "modRegistry"
Option Explicit
Private Const READ_CONTROL              As Long = &H20000
Private Const STANDARD_RIGHTS_READ      As Long = (READ_CONTROL)
Private Const STANDARD_RIGHTS_ALL       As Long = &H1F0000
Private Const KEY_QUERY_VALUE           As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS    As Long = &H8
Private Const KEY_NOTIFY                As Long = &H10
Private Const SYNCHRONIZE               As Long = &H100000
Private Const KEY_READ                  As Long = ((STANDARD_RIGHTS_READ Or _
                                                    KEY_QUERY_VALUE Or _
                                                    KEY_ENUMERATE_SUB_KEYS Or _
                                                    KEY_NOTIFY) _
                                                    And (Not SYNCHRONIZE))
Private Const BASE_KEY                  As String = "SOFTWARE"
Private Const ERROR_KEY_DOES_NOT_EXIST  As Long = 2

'******************************************************************************
' Class Variables
'******************************************************************************

'Value Type
Public Enum regValueType
    REG_SZ = 1
    REG_DWORD = 4
End Enum

'Predefined Keys
Public Enum regPredefinedKey
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
End Enum

'Errors
Public Enum regError
    ERROR_NONE = 0
    ERROR_BADDB = 1
    ERROR_BADKEY = 2
    ERROR_CANTOPEN = 3
    ERROR_CANTREAD = 4
    ERROR_CANTWRITE = 5
    ERROR_OUTOFMEMORY = 6
    ERROR_INVALID_PARAMETER = 7
    ERROR_ACCESS_DENIED = 8
    ERROR_INVALID_PARAMETERS = 87
    ERROR_NO_MORE_ITEMS = 259
End Enum

Const KEY_ALL_ACCESS As Long = &H3F

Const REG_OPTION_NON_VOLATILE = 0

'API Declarations
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
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) 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, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
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 RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)

'******************************************************************************
' Properties
'******************************************************************************

'******************************************************************************
' Public Methods
'******************************************************************************

' enumerates the subkeys under any given key
' Call repeatedly until "Not Found" is returned
' Example - this example just adds all the subkeys to a string - you will probably want to
' save then into an array or something.
'
' Dim Res As String
' Dim i As Long
' Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
' Do Until Res = "Not Found"
'   Text1.Text = Text1.Text & " " & Res
'   i = i + 1
'   Res = ReadRegistryGetSubkey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\", i)
' Loop

Public Function ReadRegistryGetSubkey(ByVal Group As Long, ByVal Section As String, Idx As Long) As String
    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long, lValueLength As Long, sValue As String, td As Double
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    lValueLength = Len(sValue)
    lResult = RegEnumKey(lKeyValue, Idx, sValue, lValueLength)
    If (lResult = 0) And (Err.Number = 0) Then
        sValue = Left$(sValue, InStr(sValue, Chr(0)) - 1)
    Else
        sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ReadRegistryGetSubkey = sValue
End Function

' get all the values from anywhere in the Registry under any
' given subkey, it currently only returns string and double word values.
' Example - returns list of names/values to multiline text box
' Dim Res As Variant
' Dim i As Long
' Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Do Until Res(2) = "Not Found"
'    Text1.Text = Text1.Text & Chr(13) & Chr(10) & Res(1) & " " & Res(2)
'    i = i + 1
'    Res = ReadRegistryGetAll(HKEY_CURRENT_USER, "Software\Microsoft\Notepad", i)
' Loop

Public Function ReadRegistryGetAll(ByVal Group As Long, ByVal Section As String, Idx As Long) As Variant
    Dim lResult As Long, lKeyValue As Long, lDataTypeValue As Long
    Dim lValueLength As Long, lValueNameLength As Long
    Dim sValueName As String, sValue As String
    Dim td As Double
    On Error Resume Next
    lResult = RegOpenKey(Group, Section, lKeyValue)
    sValue = Space$(2048)
    sValueName = Space$(2048)
    lValueLength = Len(sValue)
    lValueNameLength = Len(sValueName)
    lResult = RegEnumValue(lKeyValue, Idx, sValueName, lValueNameLength, 0&, lDataTypeValue, sValue, lValueLength)
    If (lResult = 0) And (Err.Number = 0) Then
        If lDataTypeValue = REG_DWORD Then
            td = Asc(Mid$(sValue, 1, 1)) + &H100& * Asc(Mid$(sValue, 2, 1)) + &H10000 * Asc(Mid$(sValue, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(sValue, 4, 1)))
            sValue = Format$(td, "000")
        End If
        sValue = Left$(sValue, lValueLength - 1)
        sValueName = Left$(sValueName, lValueNameLength)
    Else
        sValue = "Not Found"
    End If
    lResult = RegCloseKey(lKeyValue)
    ' Return the datatype, value name and value as an array
    ReadRegistryGetAll = Array(lDataTypeValue, sValueName, sValue)
End Function

Public Function GetStringSetting(ByVal sAppName As String, ByVal sSection As String, ByVal sKey As String, Optional ByVal sDefault As String) As String
    Dim lRetVal         As Long
    Dim sFullKey        As String
    Dim lHandle         As Long
    Dim lType           As Long
    Dim lLength         As Long
    Dim sValue          As String
    Dim lErrNumber      As Long
    Dim sErrDescription As String
    Dim sErrSource      As String
    
    On Error GoTo ERROR_HANDLER

    If Trim(sAppName) = "" Then
        Err.Raise vbObjectError + 1000, , "AppName may not be empty"
    End If
    If Trim(sSection) = "" Then
        Err.Raise vbObjectError + 1001, , "Section may not be empty"
    End If
    If Trim(sKey) = "" Then
        Err.Raise vbObjectError + 1002, , "Key may not be empty"
    End If
    
    sFullKey = BASE_KEY & "\" & Trim(sAppName) & "\" & Trim(sSection)

    ' Open up the key
    
    lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sFullKey, 0, KEY_READ, lHandle)
    If lRetVal <> ERROR_NONE Then
        If lRetVal = ERROR_KEY_DOES_NOT_EXIST Then
            GetStringSetting = sDefault
            Exit Function
        Else
            Err.Raise vbObjectError + 2000 + lRetVal, , _
                "Could not open registry section"
        End If
    End If
    
    ' Get size and type
    lRetVal = RegQueryValueExNULL(lHandle, sKey, 0, lType, 0, lLength)
    If lRetVal <> ERROR_NONE Then
        GetStringSetting = sDefault
        Exit Function
    End If
    
    ' Is it stored as a string in the registry?
    If lType = REG_SZ Then
        sValue = String(lLength, 0)
        
        If lLength = 0 Then
            GetStringSetting = vbNullString
        Else
            lRetVal = RegQueryValueExString(lHandle, sKey, 0, lType, _
                sValue, lLength)
            
            If lRetVal = ERROR_NONE Then
                GetStringSetting = Left(sValue, lLength - 1)
            Else
                GetStringSetting = sDefault
            End If
        End If
    Else
        Err.Raise vbObjectError + 2000 + lType, , _
            "Registry data not a string"
    End If
    
TIDY_UP:
    On Error Resume Next
    
    RegCloseKey lHandle
    
    If lErrNumber <> 0 Then
        On Error GoTo 0
        
        Err.Raise lErrNumber, sErrSource, sErrDescription
    End If
Exit Function

ERROR_HANDLER:
    lErrNumber = Err.Number
    sErrSource = Err.Source
    sErrDescription = Err.Description
    Resume TIDY_UP
End Function

'******************************************************************************
'    Name:  DeleteKey
'  Inputs:  Location As regPredefinedKey
'           KeyName As String
' Returns:  error code
'   Usage:  DeleteKey Location, KeyName
'           Location must be HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'           KeyName is name of the key you wish to delete, it may include subkeys (example "Key1\SubKey1")
' Example:  DeleteKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'------------------------------------------------------------------------------
' Purpose:  Deletes a key
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function DeleteKey(Location As regPredefinedKey, KeyName As String) As regError

    DeleteKey = RegDeleteKey(Location, KeyName)

End Function

'******************************************************************************
'    Name:  DeleteValue
'  Inputs:  Location As regPredefinedKey
'           KeyName As String
'           ValueName As String
' Returns:  error code
'   Usage:  DeleteValue Location, KeyName, ValueName
'           Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'           KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
'           ValueName is the name of value you wish to delete
' Example:  DeleteValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test"
'------------------------------------------------------------------------------
' Purpose:  Deletes a value
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function DeleteValue(Location As regPredefinedKey, KeyName As String, ValueName As String) As regError

    Dim lRetVal As Long      'Result of the SetValueEx function
    Dim hKey As Long         'Handle of open key

    'Attempt to open the key
    lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
       
    'If the key was opened, delete the value
    If lRetVal = ERROR_NONE Then
        
        'Delete the value
        lRetVal = RegDeleteValue(hKey, ValueName)
        
        'Close the key
        RegCloseKey (hKey)
        
    End If
       
    'Return the result
    DeleteValue = lRetVal
    
End Function

'******************************************************************************
'    Name:  CreateNewKey
'  Inputs:  Location As regPredefinedKey
'           KeyName As String
' Returns:  error code
'   Usage:  CreateNewKey Location, NewKeyName
'           Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'           KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
' Example:  CreateNewKey HKEY_CURRENT_USER, "TestKey\SubKey1\SubKey2"
'------------------------------------------------------------------------------
' Purpose:  Creates a new key
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function CreateNewKey(Location As regPredefinedKey, NewKeyName As String) As regError
    
    Dim hNewKey As Long         'Handle to the new key
    Dim lRetVal As Long         'Result of the RegCreateKeyEx function
    
    lRetVal = RegCreateKeyEx(Location, NewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    
    If lRetVal = ERROR_NONE Then
        RegCloseKey (hNewKey)
    End If
    
    'Return the result
    CreateNewKey = lRetVal
    
End Function

'******************************************************************************
'    Name:  SetKeyValue
'  Inputs:  Location As Long
'           KeyName As String
'           ValueName as String
'           ValueSetting As Variant
'           ValueType As regValueType
' Returns:  error code
'   Usage:  SetKeyValue Location, KeyName, ValueName, ValueSetting, ValueType
'           Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'           KeyName is name of the key that holds the value to delete, it may include subkeys (example "Key1\SubKey1")
'           ValueName is the name of the value you want create, or set the value of (example: "ValueTest")
'           ValueSetting is what you want the value set to
'           ValueType must equal either REG_SZ (a string) Or REG_DWORD (an integer)
' Example:  SetKeyValue HKEY_CURRENT_USER, "TestKey\SubKey1", "Test", "Testing, Testing", REG_SZ
'------------------------------------------------------------------------------
' Purpose:  Sets the data field of a value
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function SetKeyValue(Location As regPredefinedKey, KeyName As String, ValueName As String, ValueSetting As Variant, ValueType As regValueType) As regError

    Dim lRetVal As Long      'Result of the SetValueEx function
    Dim hKey As Long         'Handle of open key

    lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
    
    'If the key was opened, set the value
    If lRetVal = ERROR_NONE Then
        
        lRetVal = SetValueEx(hKey, ValueName, ValueType, ValueSetting)
        
        'Close the key
        RegCloseKey (hKey)
        
    End If
    
    'Return the result
    SetKeyValue = lRetVal
    
End Function

'******************************************************************************
'    Name:  QueryValue
'  Inputs:  Location As Long
'           KeyName As String
'           ValueName as String
' Returns:  Empty string if error | value at 'Location\KeyName\ValueName'
'   Usage:  QueryValue Location, KeyName, ValueName
'           Location must equal HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_lOCAL_MACHINE
'           KeyName is the key that the value is under (example: "Software\Microsoft\Windows\CurrentVersion\Explorer")
'           ValueName is the name of the value you want to access (example: "link")' Example:  Msgbox QueryValue(HKEY_CURRENT_USER, "TestKey\SubKey1", "Test")
'------------------------------------------------------------------------------
' Purpose:  Sets the data field of a value
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function QueryValue(Location As regPredefinedKey, KeyName As String, ValueName As String) As String

    Dim lRetVal As Long      'Result of the API functions
    Dim hKey As Long         'Handle of opened key
    Dim vValue As Variant    'Setting of queried value

    'Open the key
    lRetVal = RegOpenKeyEx(Location, KeyName, 0, KEY_ALL_ACCESS, hKey)
         
    'Query the value
    lRetVal = QueryValueEx(hKey, ValueName, vValue)
    
    'Return the value
    If Len(vValue) >= 1 Then
        QueryValue = cleanProperty(vValue)
    Else
        QueryValue = 0
    End If
    'Close the key
    RegCloseKey (hKey)
               
End Function

'******************************************************************************
'    Name:  LightWeightEncrypt
'  Inputs:  Text As String
'           EncryptKey As Integer
' Returns:  Encrypted or decrypted string
'   Usage:  Encode: SecretPassword = LightWeightEncrypt(SecretPassword, 80)
'           DeCode: SecretPassword = LightWeightEncrypt(SecretPassword, 80)
'------------------------------------------------------------------------------
' Purpose:  Lightweight encryption of a string key
'           Useful for hiding values in the registry
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Public Function LightWeightEncrypt(Text As String, EncryptKey As Integer) As String

    Dim Temp As String, RR As Integer
    
    For RR = 1 To Len(Text)
        Temp$ = Temp$ + Chr$(Asc(Mid(Text, RR, 1)) Xor EncryptKey)
    Next RR
    
    LightWeightEncrypt = Temp
    
End Function

'******************************************************************************
' Private Methods
'******************************************************************************

'******************************************************************************
'    Name:  SetValueEx
'  Inputs:  ByVal hKey As Long
'           ValueName As String
'           lType As Long
'           vValue As Variant
' Returns:  none
'------------------------------------------------------------------------------
' Purpose:  Set a value
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Private Function SetValueEx(ByVal hKey As Long, ValueName As String, lType As Long, vValue As Variant) As Long
    
    Dim lValue As Long
    Dim sValue As String

    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, ValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, ValueName, 0&, lType, lValue, 4)
        End Select

End Function

'******************************************************************************
'    Name:  QueryValueEx
'  Inputs:  lhKey As Long
'           szValueName
'           vValue As Variant
'           hKey As Long
' Returns:  none
'------------------------------------------------------------------------------
' Purpose:  Get a value
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If

        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            'all other data types not supported
            lrc = -1
    End Select

QueryValueExExit:

    QueryValueEx = lrc
    Exit Function

QueryValueExError:

    Resume QueryValueExExit

End Function

'******************************************************************************
'    Name:  cleanProperty
'  Inputs:  Property As String
' Returns:  A "cleaned" string
'------------------------------------------------------------------------------
' Purpose:  Chop of the last character because there is an end of string
'           character present when getting a string from the registry
'  Author:  John Powell
'    Date:  04.12.2001
' Changes:  none
'******************************************************************************
Private Function cleanProperty(ByVal Property As String) As String
    If Len(Property) > 1 Then
        cleanProperty = Left(Property, (Len(Property) - 1))
    Else
        cleanProperty = Property
    End If
End Function