Attribute VB_Name = "Module1"
Option Explicit

' Reg Data Types...
Global Const REG_NONE = 0                  ' No value type
Global Const REG_SZ = 1      'Unicode nul terminated string
Global Const REG_EXPAND_SZ = 2                  ' Unicode nul terminated string
Global Const REG_BINARY = 3                     ' Free form binary
Global Const REG_DWORD = 4                      ' 32-bit number
Global Const REG_DWORD_LITTLE_ENDIAN = 4        ' 32-bit number (same as REG_DWORD)
Global Const REG_DWORD_BIG_ENDIAN = 5           ' 32-bit number
Global Const REG_LINK = 6                       ' Symbolic Link (unicode)
Global Const REG_MULTI_SZ = 7                   ' Multiple Unicode strings
Global Const REG_RESOURCE_LIST = 8              ' Resource list in the resource map
Global Const REG_FULL_RESOURCE_DESCRIPTOR = 9   ' Resource list in the hardware description

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

'Registy errors
Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const SYNCHRONIZE = &H100000
Global Const STANDARD_RIGHTS_ALL = &H1F0000
' Reg Key Security Options
Global Const KEY_QUERY_VALUE = &H1
Global Const KEY_SET_VALUE = &H2
Global Const KEY_CREATE_SUB_KEY = &H4
Global Const KEY_ENUMERATE_SUB_KEYS = &H8
Global Const KEY_NOTIFY = &H10
Global Const KEY_CREATE_LINK = &H20
'Global Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))

Global Const REG_OPTION_NON_VOLATILE = 0


' MessageId: ERROR_REGISTRY_RECOVERED
' MessageText:
'  One of the fies in the Registry database had to be recovered
'  by use of a og or aternate copy.  The recovery was successfu.
Private Const ERROR_REGISTRY_RECOVERED = 14

' MessageId: ERROR_REGISTRY_CORRUPT
' MessageText:
'  The Registry is corrupt. The structure of one of the fies that contains
'  Registry data is corrupt, or the system's image of the fie in memory
'  is corrupt, or the fie coud not be recovered because the aternate
'  copy or og was absent or corrupt.
Private Const ERROR_REGISTRY_CORRUPT = 15

' MessageId: ERROR_REGISTRY_IO_FAILED
' MessageText:
'  An I/O operation initiated by the Registry faied unrecoveraby.
'  The Registry coud not read in, or write out, or fush, one of the fies
'  that contain the system's image of the Registry.
Private Const ERROR_REGISTRY_IO_FAILED = 16

' MessageId: ERROR_NOT_REGISTRY_FIE
' MessageText:
'  The system has attempted to oad or restore a fie into the Registry, but the
'  specified fie is not in a Registry fie format.
Private Const ERROR_NOT_REGISTRY_FIE = 17

' MessageId: ERROR_KEY_DELETED
' MessageText:
'  Illegal operation attempted on a Registry key which has been marked for deletion.
Private Const ERROR_KEY_DELETED = 18

' MessageId: ERROR_NO_LOG_SPACE
' MessageText:
'  System coud not aocate the required space in a Registry og.
Private Const ERROR_NO_LOG_SPACE = 19

' MessageId: ERROR_KEY_HAS_CHILDREN
' MessageText:
'  Cannot create a symboic ink in a Registry key that aready
'  has subkeys or vaues.
Private Const ERROR_KEY_HAS_CHILDREN = 20

' MessageId: ERROR_CHID_MUST_BE_VOATIE
' MessageText:
'  Cannot create a stabe subkey under a voatie parent key.
Private Const ERROR_CHID_MUST_BE_VOATIE = 21

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
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
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
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

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
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
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
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
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
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long

Public Function CreateNewKey(Root As Long, sNewKeyName As String, sKey As String) As Boolean
'Create a new registry key
'
'Parameters:
'Root        - the long value of the root key (HKLM, HKCU, etc) see declarations above
'sNewKeyName - the name of the new key to create
'sKey        - The key that will contain the new key (full path, without a leading '\')
'
'Returns:
'True       - success
'False      - failure
'
'Example:
'  bRet = CreateNewKey(HKEY_LOCAL_MACHINE, "NewKey", "ExistingKey\CurrentVersion")
    
    Dim hKey As Long            'handle to the existing key
    Dim hNewKey As Long         'handle to the new key
    Dim lRetVal As Long         'result of the RegCreateKeyEx function
    
    lRetVal = RegOpenKeyEx(Root, sKey, Zero, KEY_ALL_ACCESS, hKey)
    If lRetVal Then
        HandleRegErr lRetVal
        CreateNewKey = False
        Exit Function
    End If
    lRetVal = RegCreateKeyEx(hKey, sNewKeyName, 0&, _
              vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _
              0&, hNewKey, lRetVal)
    If lRetVal Then
        HandleRegErr lRetVal
        lRetVal = RegCloseKey(hKey)
        CreateNewKey = False
        Exit Function
    End If
    lRetVal = RegCloseKey(hNewKey)
    lRetVal = RegCloseKey(hKey)
    
    CreateNewKey = True
End Function

Public Function SetKeyValue(Root As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long) As Boolean
'Set a value in the registry
'
'Parameters:
'Root           - the long value of the root key (HKLM, HKCU, etc) see declarations above
'sKeyName       - key to contain the value
'sValueName     - name of the value
'vValueSetting  - value to store in the registry
'lValueType     - reg data type of value (see declarations)
'
'Return:
'True           - success
'False          - Failure
'
'Example:
'  bRet = SetKeyValue(HKEY_LOCAL_MACHINE, "Key\SubKey", "ValueName", "String to Store", REG_SZ)
    
    Dim Zero As Long
    Dim lRetVal As Long
    Dim hKey As Long
    Dim OrigKeyNam As String
     
     'open the specified key
    lRetVal = RegOpenKeyEx(Root, sKeyName, Zero, KEY_ALL_ACCESS, hKey)
    If IRetVal Then
        HandleRegErr lRetVal
        SetKeyValue = False
        Exit Function
    End If
    lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
    If lRetVal Then
        HandleRegErr lRetVal
        SetKeyValue = False
        lRetVal = RegCloseKey(hKey)
        Exit Function
    End If
    
    lRetVal = RegCloseKey(hKey)
    SetKeyValue = True
End Function

Public Function QueryValue(Root As Long, sKeyName As String, sValueName As String) As Boolean
    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

    lRetVal = RegOpenKeyEx(Root, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    If lRetVal Then
        HandleRegErr lRetVal
        QueryValue = False
        Exit Function
    End If
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    If lRetVal Then
        HandleRegErr lRetVal
        QueryValue = False
        lRetVal = RegCloseKey(hKey)
        Exit Function
    End If
    
    lRetVal = RegCloseKey(hKey)
    QueryValue = True
End Function


Private Function SetValueEx(ByVal hKey As Long, sValueName 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 & Chr$(0)
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)

        End Select

End Function

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
            'Other data types not supported
            lrc = -1
    End Select

QueryValueExExit:
   QueryValueEx = lrc
    Exit Function

QueryValueExError:
    Resume QueryValueExExit
End Function

Public Function DeleteKey(Root As Long, sKey As String, strSubKey As String) As Boolean
'Delete a key from the registry
'
'Parameters:
'Root       - the long value of the root key (HKLM, HKCU, etc) see declarations above
'sKey       - name of the key containing the key to be deleted
'strSubKey  - Name of the key to be deleted
'
'Return:
'True on success, false on failure
    
    Dim hKey As Long
    Dim lRetVal As Long
    Dim Zero As Long
    
    lRetVal = RegOpenKeyEx(Root, sKey, Zero, KEY_ALL_ACCESS, hKey)
    If lRetVal Then
        HandleRegErr lRetVal
        DeleteKey = False
        Exit Function
    End If
    lRetVal = RegDeleteKey(hKey, strSubKey)
    If lRetVal Then
        HandleRegErr lRetVal
        lRetVal = RegCloseKey(hKey)
        DeleteKey = False
        Exit Function
    End If
    lRetVal = RegCloseKey(hKey)
    DeleteKey = True
End Function

Private Sub HandleRegErr(lRegError As Long)
'Displays a message for any registry errors
'
'Parameter:
'lRegError          - the return code from a registry function
    
    Select Case lRegError
        Case ERROR_BADKEY
            MsgBox "The registry key is invalid."
        Case ERROR_CANTOPEN
            MsgBox "The registry key could not be opened."
        Case ERROR_CANTREAD
            MsgBox "The registry key could not be read."
        Case ERROR_CANTWRITE
            MsgBox "The registry key could not be written."
        Case ERROR_REGISTRY_RECOVERED
            MsgBox "One of the files in the Registry database had to be recovered by use of a log or alternate copy.  The recovery was successful."
        Case ERROR_REGISTRY_CORRUPT
            MsgBox "The Registry is corrupt. The structure of one of the files that contains Registry data is corrupt, or the system's image of the file in memory is corrupt, or the file could not be recovered because the alternate copy or log was absent or corrupt."
        Case ERROR_REGISTRY_IO_FAILED
            MsgBox "An I/O operation initiated by the Registry failed unrecoverably.  The Registry coud not read in, or write out, or flush, one of the files that contain the system's image of the Registry."
        Case ERROR_NOT_REGISTRY_FIE
            MsgBox "The system has attempted to load or restore a file into the Registry, but the specified file is not in a Registry file format."
        Case ERROR_KEY_DELETED
            MsgBox "Illegal operation attempted on a Registry key which has been marked for deletion."
        Case ERROR_NO_LOG_SPACE
            MsgBox "System coud not allocate the required space in a Registry log."
        Case ERROR_KEY_HAS_CHILDREN
            MsgBox "Cannot create a symbolic link in a Registry key that already has subkeys or values."
        Case ERROR_CHID_MUST_BE_VOATIE
            MsgBox "Cannot create a stalbe subkey under a volatie parent key."
        Case Else
            MsgBox "Registry error " & lRegError & " occurred."
    End Select
    
End Sub