Attribute VB_Name = "Module1"
' basRegistry
' Replacement for Chapter 16
' Access 2000 Developer's Handbook, Volume I
' Ken Getz, Paul Litwin, and Mike Gilbert

Option Compare Database
Option Explicit

Public Type FILETIME
    dwLowDateTime As Long
    dwHightDateTime As Long
End Type

Private Const conErrInvalidType = vbObjectError + 1956
Private Const conErrCantOpenKey = vbObjectError + 1957
Private Const conErrCantSetValue = vbObjectError + 1958

Private Const Synchronize = &H100000

Public Const APPLICATION_ERROR_MASK = &H20000000
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Private Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const SPECIFIC_RIGHTS_ALL = &HFFFF&
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_SET_VALUE = &H2&
Private Const KEY_CREATE_SUB_KEY = &H4&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_CREATE_LINK = &H20&
Private Const KEY_NOTIFY = &H10&
Public Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Private Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Private Const KEY_ALL_ACCESS = READ_CONTROL 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


Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_USERS = &H80000003
Private Const HKEY_PERFORMANCE_DATA = &H80000004
Private Const HKEY_CURRENT_CONFIG = &H80000005
Private Const HKEY_DYN_DATA = &H80000006

Private Const ERROR_SUCCESS = &H0&
Public Const ERROR_SEVERITY_SUCCESS = &H0&
Private Const REG_NONE = 0
Private Const REG_SZ = 1
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_LINK = 6
Private Const REG_MULTI_SZ = 7
Private Const REG_RESOURCE_LIST = 8
Private Const REG_FULL_RESOURCE_DESCRIPTOR = 9
Private Const REG_RESOURCE_REQUIREMENTS_LIST = 10

Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Integer
End Type

Public Declare Function adh_apiRegQueryValueEx _
 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

Public Declare Function adh_apiRegEnumKeyEx _
 Lib "advapi32.dll" Alias "RegEnumKeyExA" _
 (ByVal hKey As Long, _
 ByVal dwIndex As Long, _
 ByVal lpName As String, _
 lpcbName As Long, _
 ByVal lpReserved As Long, _
 ByVal lpClass As String, _
 lpcbClass As Long, _
 lpftLastWriteTime As FILETIME) As Long

Public Declare Function adh_apiRegEnumValue _
 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

Public Declare Function adh_apiRegQueryInfoKey _
 Lib "advapi32.dll" Alias "RegQueryInfoKeyA" _
 (ByVal hKey As Long, ByVal lpClass As String, _
 lpcbClass As Long, ByVal lpReserved As Long, _
 lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, _
 lpcbMaxClassLen As Long, lpcValues As Long, _
 lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, _
 lpcbSecurityDescriptor As Long, _
 lpftLastWriteTime As FILETIME) As Long

Private Declare Function adh_apiRegCreateKeyEx _
 Lib "advapi32.dll" Alias "RegCreateKeyExA" _
 (ByVal hKey As Long, ByVal lpSubKey As String, _
 ByVal ulReserved As Long, ByVal lpClass As String, _
 ByVal dwOptions As Long, ByVal samDesired As Long, _
 lpSecurityAttributes As Any, _
 phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function adh_apiRegSetValueEx _
  Lib "advapi32" Alias "RegSetValueExA" _
  (ByVal hKey As Long, ByVal lpValueName As String, _
  ByVal Reserved As Long, ByVal dwType As Long, _
  lpData As Any, ByVal cbData As Long) As Long

Public Declare Function adh_apiRegCloseKey _
  Lib "advapi32" Alias "RegCloseKey" _
  (ByVal hKey As Long) As Long

Public Declare Function adh_apiRegOpenKeyEx _
  Lib "advapi32" Alias "RegOpenKeyExA" _
  (ByVal hKey As Long, ByVal lpszSubKey As String, _
  ByVal dwReserved As Long, ByVal samDesired As Long, _
  ByRef hKey As Long) As Long

Public Function adhGetRegistryKeys(ByVal hKey As Long) As String
    ' Returns a semi-colon separated list of all of
    ' the sub-keys of this key
    '
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   A Registry Handle to a key
    '
    ' Out:
    '   A semi-colon separated list of all the sub-keys
    '
    ' Example:
    '   varRet = adhGetRegistryKeys(hKey)

    Dim strRet As String
    Dim lngRet As Long
    Dim strClassName As String
    Dim cchClassName As Long
    Dim lngCSubKeys As Long
    Dim cchMaxSubKey As Long
    Dim cchMaxClass As Long
    Dim lngCValues As Long
    Dim cchMaxValueName As Long
    Dim cbMaxValueData As Long
    Dim cbSecurityDescriptor As Long
    Dim ftLastWrite As FILETIME
    Dim i As Long
    Dim strKey As String
    Dim cchKey As Long
    Dim strClass As String
    Dim cchClass As Long
    Dim retCode As Long

    strRet = ""
    strClassName = Space$(256)
    cchClassName = Len(strClassName)
    Call adh_apiRegQueryInfoKey(hKey, strClassName, _
     cchClassName, 0&, lngCSubKeys, cchMaxSubKey, _
     cchMaxClass, lngCValues, cchMaxValueName, _
     cbMaxValueData, cbSecurityDescriptor, ftLastWrite)
    For i = 0 To lngCSubKeys - 1
        strKey = Space$(cchMaxSubKey)
        cchKey = Len(strKey) + 1
        strClass = Space$(cchMaxClass)
        cchClass = Len(strClass) + 1
        retCode = adh_apiRegEnumKeyEx(hKey, i, strKey, _
            cchKey, 0&, strClass, cchClass, ftLastWrite)
        Select Case retCode And APPLICATION_ERROR_MASK
        Case ERROR_SEVERITY_SUCCESS
        Case Else
            Stop
            Exit For
        End Select
        strKey = Left$(strKey, cchKey)
        strRet = strRet & strKey & ";"
    Next i

    adhGetRegistryKeys = strRet
End Function

Public Function adhGetRegistryValues(ByVal hKey As Long) As String
    ' Returns a semi-colon separated list of all of
    ' the values of this key
    '
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   A Registry Handle to a key
    '
    ' Out:
    '   A semi-colon separated list of all the values
    '
    ' Example:
    '   varRet = adhGetRegistryValues(hKey)

    Dim strRet As String
    Dim lngRet As Long
    Dim strClassName As String
    Dim cchClassName As Long
    Dim lngCSubKeys As Long
    Dim cchMaxSubKey As Long
    Dim cchMaxClass As Long
    Dim lngCValues As Long
    Dim cchMaxValueName As Long
    Dim cbMaxValueData As Long
    Dim cbSecurityDescriptor As Long
    Dim ftLastWrite As FILETIME
    Dim i As Long
    Dim strValue As String
    Dim cchValue As Long
    Dim retCode As Long
    Dim lngType As Long
    Dim cchLen As Long

    strRet = ""
    strClassName = Space$(256)
    cchClassName = Len(strClassName)
    retCode = adh_apiRegQueryInfoKey(hKey, strClassName, _
        cchClassName, 0&, lngCSubKeys, cchMaxSubKey, _
        cchMaxClass, lngCValues, cchMaxValueName, _
        cbMaxValueData, cbSecurityDescriptor, ftLastWrite)
    Select Case retCode And APPLICATION_ERROR_MASK
    Case ERROR_SEVERITY_SUCCESS
        For i = 0 To lngCValues - 1
            strValue = Space$(cchMaxValueName)
            cchValue = Len(strValue) + 1
            retCode = adh_apiRegEnumValue(hKey, i, strValue, _
                cchValue, ByVal 0&, lngType, ByVal 0&, cchLen)
            Select Case retCode And APPLICATION_ERROR_MASK
            Case ERROR_SEVERITY_SUCCESS
            Case Else
                Stop
                Exit For
            End Select
            strValue = Left$(strValue, cchValue)
            strRet = strRet & "'" & strValue & "';"
        Next i
    Case Else
        Stop
    End Select

    adhGetRegistryValues = strRet
End Function

Public Function adhGetRegistryValue(ByVal hKey As Long, ByVal strValue As String) As Variant
    ' Returns a registry value based on an hKey
    ' and a strValue
    '
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   hKey        A Registry Handle to a key
    '   strValue    A registry Value
    '
    ' Out:
    '   The contents of the value
    '
    ' Example:
    '   varRet = adhGetRegistryValue(hKey, strValue)

    Dim retCode As Long
    Dim lngType As Long
    Dim cbData As Long
    Dim strGetValue As String
    Dim lngValue As Long

    adhGetRegistryValue = "<Binary Data>"
    retCode = adh_apiRegQueryValueEx(hKey, strValue, 0&, _
        lngType, ByVal 0&, cbData)
    
    Select Case retCode And APPLICATION_ERROR_MASK
        Case ERROR_SEVERITY_SUCCESS
            Select Case lngType
                Case REG_NONE
                    adhGetRegistryValue = CVErr(0)
                Case REG_SZ, REG_EXPAND_SZ
                    strGetValue = Space$(cbData)
                    retCode = adh_apiRegQueryValueEx( _
                     hKey, strValue, 0&, lngType, _
                     ByVal strGetValue, cbData)
                    adhGetRegistryValue = strGetValue
                Case REG_BINARY
                Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
                    retCode = adh_apiRegQueryValueEx( _
                     hKey, strValue, 0&, lngType, _
                     lngValue, cbData)
                    adhGetRegistryValue = lngValue
                Case REG_DWORD_BIG_ENDIAN
                Case REG_LINK
                Case REG_MULTI_SZ
                Case REG_RESOURCE_LIST
                Case REG_FULL_RESOURCE_DESCRIPTOR
                Case REG_RESOURCE_REQUIREMENTS_LIST
                Case Else
                    Stop
            End Select
        Case Else
            Debug.Assert False  ' Should never happen
    End Select
End Function

Public Function adhGetRegistryValueFromPath(strPath As String) As Variant
    ' Returns the value from a registry path
    '
    ' From Access 2000 Developer's Handbook, Volume I
    ' by Getz, Litwin, and Gilbert. (Sybex)
    ' Copyright 1999. All Rights Reserved.
    '
    ' In:
    '   strPath     A registry path
    '
    ' Out:
    '   The contents of the value specified
    '
    ' Example:
    '   Call adhGetRegistryValueFromPath("\HKEY_CURRENT_USER\Control Panel\Desktop\ScreenSaveActive")

    On Error GoTo HandleErr

    Dim hKey As Long
    Dim strValue As String

    Call GetHKeyAndValueNameFromPath(strPath, hKey, strValue)
    adhGetRegistryValueFromPath = GetRegValue(hKey, strValue)
    Call adh_apiRegCloseKey(hKey)
    
ExitHere:
    Exit Function
    
HandleErr:
    Err.Raise Err.Number
    Resume ExitHere
End Function

Public Sub adhSetRegistryValueFromPath _
 (ByVal strPath As String, ByVal varValue As Variant, _
 Optional ByVal ValueType As VbVarType = vbString)
    
    ' Sets a value based on a registry path
    '
    ' In:
    '     strPath     A registry path
    '     varValue    The value to be set
    '                 The VarType of the variant determines
    '                 What data type in the registry is
    '                 used
    '
    '
    ' Example:
    '     Call adhSaveRegValueFromPath("\HKEY_CURRENT_USER\Control Panel\Desktop\ScreenSaveActive", "1")

    Dim hKey As Long
    Dim strValueName As String
    Dim retCode As Long

    Call GetHKeyAndValueNameFromPath(strPath, hKey, strValueName)
    
    Select Case ValueType
        Case vbLong, vbInteger
            retCode = adh_apiRegSetValueEx(hKey, strValueName, _
                0&, REG_DWORD, CLng(varValue), 4)
            Select Case retCode
                Case ERROR_SUCCESS
                Case Else
                    Err.Raise conErrCantSetValue
            End Select
            
        Case Else
            ' For this routine, if you pass anything besides
            ' an integer, we store it as a string.
            Dim strValue As String
            Dim cb As Long
            
            strValue = varValue & ""
            cb = Len(strValue) + 1
            retCode = adh_apiRegSetValueEx(hKey, strValueName, _
                0&, REG_SZ, ByVal strValue, cb)
            Select Case retCode
                Case ERROR_SUCCESS
                Case Else
                    Err.Raise conErrCantSetValue
        End Select
    End Select
    Call adh_apiRegCloseKey(hKey)
End Sub

Private Function GetRegValue( _
 ByVal hKey As Long, ByVal strValue As String) As Variant
    ' Returns a registry value based on an hKey
    ' and a Value name.
    '
    ' In:
    '     hKey        A Registry Handle to a key
    '     strValue    A registry Value
    '
    ' Out:
    '     The contents of the value
    '
    ' Example:
    '     varRet = GetRegistryValue(hKey, strValue)

    Dim retCode As Long
    Dim lngType As Long
    Dim cbData As Long
    Dim strGetValue As String
    Dim lngValue As Long

    retCode = adh_apiRegQueryValueEx(hKey, strValue, 0&, _
        lngType, ByVal 0&, cbData)
    Select Case retCode
        Case ERROR_SUCCESS
            Select Case lngType
                Case REG_SZ, REG_EXPAND_SZ
                    strGetValue = Space$(cbData)
                    retCode = adh_apiRegQueryValueEx(hKey, strValue, _
                        0&, lngType, ByVal strGetValue, cbData)
                    GetRegValue = TrimNull(strGetValue)
                Case REG_DWORD
                    retCode = adh_apiRegQueryValueEx(hKey, strValue, _
                        0&, lngType, lngValue, cbData)
                    GetRegValue = lngValue
                Case Else
                    Err.Raise conErrInvalidType
            End Select
        Case Else
            Err.Raise conErrCantOpenKey
    End Select
End Function

Private Function GetHKeyAndValueNameFromPath _
 (ByVal strPath As String, ByRef hKey As Long, _
    ByRef strValue As String) As Variant
    ' Breaks up the path into a hKey and a strValue
    '
    ' In:
    '     strPath     A Registry path
    '
    ' Out:
    '     hKey        A handle to a key representing the key
    '                 portion of the path
    '     strValue    A string representing the value portion of
    '                 the path
    '
    ' Warning:
    '     The hKey must be closed with RegClose(hKey) after
    '     the call if the function is successful

    Dim hKeyNew As Long
    Dim i As Long
    Dim lngRet As Long
    Dim varItems As Variant
    Dim lngDisp As Long
    
    ' Get rid of leading "\"
    If Left(strPath, 1) = "\" Then
        strPath = Mid$(strPath, 2)
    End If
    varItems = Split(strPath, "\")
    strValue = varItems(UBound(varItems))

    Select Case varItems(LBound(varItems))
        Case "HKEY_CLASSES_ROOT"
            hKey = HKEY_CLASSES_ROOT
        Case "HKEY_CURRENT_USER"
            hKey = HKEY_CURRENT_USER
        Case "HKEY_LOCAL_MACHINE"
            hKey = HKEY_LOCAL_MACHINE
        Case "HKEY_USERS"
            hKey = HKEY_USERS
        Case "HKEY_CURRENT_CONFIG"
            hKey = HKEY_CURRENT_CONFIG
        Case "HKEY_DYN_DATA"
            hKey = HKEY_DYN_DATA
        Case Else
            Err.Raise conErrCantOpenKey
    End Select

    For i = LBound(varItems) + 1 To UBound(varItems) - 1
        ' lngDisp will contain 1 if the code created
        ' a new key, or 2 if it opened an existing one.
        lngRet = adh_apiRegCreateKeyEx(hKey, _
         varItems(i), 0&, "", 0, _
         KEY_ALL_ACCESS, ByVal 0&, hKeyNew, lngDisp)
        Select Case lngRet
            Case ERROR_SUCCESS
                Call adh_apiRegCloseKey(hKey)
                hKey = hKeyNew
            Case Else
                Err.Raise conErrCantOpenKey
        End Select
    Next i
End Function

Private Function TrimNull(ByVal strValue As String) As String
    ' Find the first vbNullChar in a string, and return
    ' everything prior to that character. Extremely
    ' useful when combined with the Windows API function calls.
    
    ' In:
    '   strValue:
    '       Input text, possibly containing a null character
    '       (chr$(0), or vbNullChar)
    ' Out:
    '   Return Value:
    '       strValue trimmed on the right, at the location
    '       of the null character, if there was one.
    
    Dim intPos As Integer
    
    intPos = InStr(strValue, vbNullChar)
    Select Case intPos
        ' It's best to put the most likely case first.
        Case Is > 1
            ' Found in the string, so return the portion
            ' up to the null character.
            TrimNull = Left$(strValue, intPos - 1)
        Case 0
            ' Not found at all, so just
            ' return the original value.
            TrimNull = strValue
        Case 1
            ' Found at the first position, so return
            ' an empty string.
            TrimNull = ""
    End Select
End Function