Option Explicit

' --------------------------------------------------------------
' Update the Windows registry.
' Written by Kenneth Ives            kenaso@home.com
' NT tested by Brett Gerhardi    Brett.Gerhardi@trinite.co.uk
'
' Perform the four basic functions on the Windows registry.
'      Add
'      Change
'      Delete
'      Query
'
' Software developers vary on where they want to update the
' registry with their particular information. The most common
' are in HKEY_lOCAL_MACHINE or HKEY_CURRENT_USER.
'
' This BAS module handles all of my needs for string and
' basic numeric updates in the Windows registry.
'
' Brett found that NT users must delete each major key
' separately. See bottom of TEST routine for an example.
' --------------------------------------------------------------

' Private variables
Private m_lngRetVal As Long

' Constants required for key locations in the registry
Public Const HKEY_CLASSES_ROOT As Long = &H80000000
Public Const HKEY_CURRENT_USER As Long = &H80000001
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_USERS As Long = &H80000003
Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
Public Const HKEY_DYN_DATA As Long = &H80000006

'  Constants required for values in the keys
Public Const REG_NONE As Long = 0           ' No value type
Public Const REG_SZ As Long = 1            ' null-terminated string
Public Const REG_EXPAND_SZ As Long = 2         ' null-terminated string w/environment var
Public Const REG_BINARY As Long = 3          ' Free-form binary
Public Const REG_DWORD As Long = 4           ' 32-bit number
Public Const REG_DWORD_LITTLE_ENDIAN As Long = 4    ' 32-bit number (same as REG_DWORD)
Public Const REG_DWORD_BIG_ENDIAN As Long = 5     ' 32-bit number
Public Const REG_LINK As Long = 6           ' Symbolic Link (unicode)
Public Const REG_MULTI_SZ As Long = 7         ' Multiple Unicode strings
Public Const REG_RESOURCE_LIST As Long = 8       ' Resource list in the resource map
Public Const REG_FULL_RESOURCE_DESCRIPTOR As Long = 9 ' Resource list in the hardware description
Public Const REG_RESOURCE_REQUIREMENTS_LIST As Long = 10

' Registry Specific Access Rights
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_CREATE_LINK As Long = &H20
Private Const KEY_ALL_ACCESS As Long = &H3F

' Constants required for return values (Error code checking)
Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_NO_MORE_ITEMS As Long = 259

' Open/Create constants
Private Const REG_OPTION_NON_VOLATILE As Long = 0
Private Const REG_OPTION_VOLATILE As Long = &H1

' Declarations required to access the Windows registry
Private Declare Function RegCloseKey Lib "advapi32.dll" _
  (ByVal lngRootKey As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" _
  Alias "RegCreateKeyA" (ByVal lngRootKey As Long, _
              ByVal lpSubKey As String, _
              phkResult As Long) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" _
  Alias "RegDeleteKeyA" (ByVal lngRootKey As Long, _
              ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" _
  Alias "RegDeleteValueA" (ByVal lngRootKey As Long, _
               ByVal lpValueName As String) As Long

Private Declare Function RegOpenKey Lib "advapi32.dll" _
  Alias "RegOpenKeyA" (ByVal lngRootKey As Long, _
             ByVal lpSubKey As String, _
             phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
  Alias "RegQueryValueExA" (ByVal lngRootKey As Long, _
               ByVal lpValueName As String, _
               ByVal lpReserved As Long, _
               lpType As Long, _
               lpData As Any, _
               lpcbData As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" _
  Alias "RegSetValueExA" (ByVal lngRootKey As Long, _
              ByVal lpValueName As String, _
              ByVal Reserved As Long, _
              ByVal dwType As Long, _
              lpData As Any, _
              ByVal cbData As Long) As Long

Public Function registryCreateKey(ByVal lngRootKey As Long, _
                 ByVal strRegKeyPath As String) As Boolean
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  This function will create a new key
'
' Parameters:
'     lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'         HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key you wish to create.
'         to make sub keys, continue to make this
'         call with each new level. MS says you
'         can do this in one call; however, the
'         best laid plans of mice and men ...
'
' Syntax:
'  registryCreateKey HKEY_CURRENT_USER, "Software\AAA-Registry Test"
'  registryCreateKey HKEY_CURRENT_USER, "Software\AAA-Registry Test\Products"
' --------------------------------------------------------------
  
  ' Define variables
  Dim lngKeyHandle As Long
  
  ' Preset to a failed create
  registryCreateKey = False
  
  ' Create the key. If it already exist, ignore it.
  m_lngRetVal = RegCreateKey(lngRootKey, strRegKeyPath, lngKeyHandle)
  
  ' Always close the handle in the registry. We do not want to
  ' corrupt these files.
  m_lngRetVal = RegCloseKey(lngKeyHandle)
  registryCreateKey = True
End Function

Public Function registryCreateValue _
    (ByVal lngRootKey As Long, _
    ByVal strRegKeyPath As String, _
    ByVal strRegSubKey As String, _
    varRegData As Variant, _
    Optional lngDataType As Long = -1) As Boolean
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  Function for saving string data.
'
' Parameters:
'      lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'         HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key path you wish to traverse.
'   strRegSubKey - is the name of the key which will be updated.
'    varRegData - Update data.
'
' Syntax:
'  registryCreateValue HKEY_CURRENT_USER, _
'           "Software\AAA-Registry Test\Products", _
'           "StringTestData", "22 Jun 1999"
'
' Saves the key value of "22 Jun 1999" to sub key "StringTestData"
' --------------------------------------------------------------
  
  ' Define variables
  Dim lngKeyHandle As Long
  Dim lngKeyValue As Long
  Dim strKeyValue As String
  
  ' Preset to a failed create
  registryCreateValue = False
  
  ' Query the key path
  m_lngRetVal = RegCreateKey(lngRootKey, _
                strRegKeyPath, _
                lngKeyHandle)
  
  If lngDataType = -1 And IsNumeric(varRegData) Then
    lngDataType = REG_DWORD
  Else
    lngDataType = REG_SZ
  End If
  
  ' Update the sub key based on the data type
  Select Case lngDataType
    Case REG_SZ:    ' String data
      strKeyValue = Trim(varRegData) & Chr(0)   ' null terminated
      m_lngRetVal = RegSetValueEx(lngKeyHandle, _
                    strRegSubKey, _
                    0&, _
                    lngDataType, _
                    ByVal strKeyValue, _
                    Len(strKeyValue))
    Case REG_DWORD:  ' numeric data
      lngKeyValue = CLng(varRegData)
      m_lngRetVal = RegSetValueEx(lngKeyHandle, _
                    strRegSubKey, _
                    0&, _
                    lngDataType, _
                    lngKeyValue, 4&) ' 4& = 4-byte word (long integer)
  End Select
  
  ' Always close the handle in the registry. We do not want to
  ' corrupt these files.
  m_lngRetVal = RegCloseKey(lngKeyHandle)
  registryCreateValue = True
End Function

Public Function registryDeleteKey _
    (ByVal lngRootKey As Long, _
    ByVal strRegKeyPath As String, _
    ByVal strRegKeyName As String) As Boolean
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  Function for removing a complete key.
'
' Parameters:
'      lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'            HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key path you wish to traverse.
'  strRegKeyValue - is the name of the key which will be removed.
'
' Returns a True or False on completion.
'
' Syntax:
'  registryDeleteKey HKEY_CURRENT_USER, "Software", "AAA-Registry Test"
'
' Removes the key "AAA-Registry Test" and all of its sub keys.
' --------------------------------------------------------------
  
  ' Define variables
  Dim lngKeyHandle As Long
  
  ' Make sure the key exist before trying to delete it
  If registryKeyExists(lngRootKey, strRegKeyPath) Then
    ' Preset to a failed delete
    registryDeleteKey = False
    
    ' Get the key handle
    m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
    
    ' Delete the key
    m_lngRetVal = RegDeleteKey(lngKeyHandle, strRegKeyName)
    
    ' If the value returned is equal zero then we have succeeded
    If m_lngRetVal = 0 Then registryDeleteKey = True
    
    ' Always close the handle in the registry. We do not want to
    ' corrupt the registry.
    m_lngRetVal = RegCloseKey(lngKeyHandle)
  End If
End Function

Public Function registryDeleteValue _
    (ByVal lngRootKey As Long, _
    ByVal strRegKeyPath As String, _
    ByVal strRegSubKey As String) As Boolean
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  Function for removing a sub key.
'
' Parameters:
'      lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'         HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key path you wish to traverse.
'   strRegSubKey - is the name of the key which will be removed.
'
' Syntax:
'  registryDeleteValue HKEY_CURRENT_USER, _
         "Software\AAA-Registry Test\Products", "StringTestData"
'
' Removes the sub key "StringTestData"
' --------------------------------------------------------------
  
  ' Define variables
  Dim lngKeyHandle As Long
  
  ' Make sure the key exist before trying to delete it
  If registryKeyExists(lngRootKey, strRegKeyPath) Then
    ' Preset to a failed delete
    registryDeleteValue = False
    
    ' Get the key handle
    m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
    
    ' Delete the sub key. If it does not exist, then ignore it.
    m_lngRetVal = RegDeleteValue(lngKeyHandle, strRegSubKey)
    
    ' Always close the handle in the registry. We do not want to
    ' corrupt the registry.
    m_lngRetVal = RegCloseKey(lngKeyHandle)
    registryDeleteValue = True
  End If
End Function

Public Function registryKeyExists _
    (ByVal lngRootKey As Long, _
    ByVal strRegKeyPath As String) As Boolean
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  Function to see if a key does exist
'
' Parameters:
'      lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'         HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key path you want to test
'
' Syntax:
'  strKeyQuery = regQueryValue(HKEY_CURRENT_USER, _
'            "Software\AAA-Registry Test\Products")
'
' Returns the value of TRUE or FALSE
' --------------------------------------------------------------
  
  ' Define variables
  Dim lngKeyHandle As Long
  
  ' Initialize variables
  lngKeyHandle = 0
  
  ' Query the key path
  m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
  
  ' If no key handle was found then there is no key. Leave here.
  If lngKeyHandle = 0 Then
    registryKeyExists = False
  Else
    registryKeyExists = True
  End If
  
  ' Always close the handle in the registry. We do not want to
  ' corrupt these files.
  m_lngRetVal = RegCloseKey(lngKeyHandle)
End Function

Public Function registryQueryValue _
    (ByVal lngRootKey As Long, _
    ByVal strRegKeyPath As String, _
    ByVal strRegSubKey As String) As Variant
  
' --------------------------------------------------------------
' Written by Kenneth Ives           kenaso@home.com
'
' Description:  Function for querying a sub key value.
'
' Parameters:
'      lngRootKey - HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
'         HKEY_lOCAL_MACHINE, HKEY_USERS, etc
'  strRegKeyPath - is name of the key path you wish to traverse.
'   strRegSubKey - is the name of the key which will be queryed.
'
' Syntax:
'  strKeyQuery = registryQueryValue(HKEY_CURRENT_USER, _
'            "Software\AAA-Registry Test\Products", _
            "StringTestData")
'
' Returns the key value of "StringTestData"
' --------------------------------------------------------------
  
  ' Define variables
  Dim intPosition As Integer
  Dim lngKeyHandle As Long
  Dim lngDataType As Long
  Dim lngBufferSize As Long
  Dim lngBuffer As Long
  Dim strBuffer As String
  
  ' Initialize variables
  lngKeyHandle = 0
  lngBufferSize = 0
  
  ' Query the key path
  m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
  
  ' If no key handle was found then there is no key. Leave here.
  If lngKeyHandle = 0 Then
    registryQueryValue = ""
    m_lngRetVal = RegCloseKey(lngKeyHandle)  ' always close the handle
    Exit Function
  End If
  
  ' Query the registry and determine the data type.
  m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, _
    lngDataType, ByVal 0&, lngBufferSize)
  
  ' If no key handle was found then there is no key. Leave.
  If lngKeyHandle = 0 Then
    registryQueryValue = ""
    m_lngRetVal = RegCloseKey(lngKeyHandle)  ' always close the handle
    Exit Function
  End If
  
  ' Make the API call to query the registry based on the type of data.
  Select Case lngDataType
    Case REG_SZ:    ' String data (most common)
      ' Preload the receiving buffer area
      strBuffer = Space(lngBufferSize)
      
      m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, 0&, _
        ByVal strBuffer, lngBufferSize)
      
      ' If NOT a successful call then leave
      If m_lngRetVal <> ERROR_SUCCESS Then
        registryQueryValue = ""
      Else
        ' Strip out the string data
        intPosition = InStr(1, strBuffer, Chr(0)) ' look for the first null char
        If intPosition > 0 Then
          ' if we found one, then save everything up to that point
          registryQueryValue = Left(strBuffer, intPosition - 1)
        Else
          ' did not find one. Save everything.
          registryQueryValue = strBuffer
        End If
      End If
    
    Case REG_DWORD:  ' Numeric data (Integer)
      m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, lngDataType, _
        lngBuffer, 4&) ' 4& = 4-byte word (long integer)
      
      ' If NOT a successful call then leave
      If m_lngRetVal <> ERROR_SUCCESS Then
        registryQueryValue = ""
      Else
        ' Save the captured data
        registryQueryValue = lngBuffer
      End If
      
    Case Else:  ' unknown
      registryQueryValue = ""
  End Select
  
  ' Always close the handle in the registry. We do not want to
  ' corrupt these files.
  m_lngRetVal = RegCloseKey(lngKeyHandle)
End Function