VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "Registry" Attribute VB_GlobalNameSpace = True Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = True Option Explicit '****************************************************************************** '* Name Win32 Registry Class '* '* Author (c)Mark Wilson, Batt Cables Ltd. '* '* Purpose Provides a more sophisticated mechanism for accessing the '* registry using Visual Basic. This module essential hides '* the complexity of the Win32 API from standard VB code. '* '* Functions PUBLIC: '* RegCreateKey '* RegGetValue '* RegSetValue '* RegEnumValues '* '* PRIVATE '* OpenKey '* '* Errors Raised enum REGISTRY_ERROR_CODE '* '* Events Raised None '* '* Compatibility: MS-Windows 2000 '* MS-Visual Basic 6 or above '* '* Version 14/08/2001 Mark Wilson Created '* 25/09/2001 MW Added RegEnumValues '* 12/03/2002 MW Added RegDeleteKey '* '******************************************************************************* '***************************** '* Win32 Function Stubs . . . '***************************** Private Declare Function RegCreateKeyExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long Private Declare Function RegOpenKeyExA Lib "advapi32.dll" (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 RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Any, lpcbData As Long) As Long Private Declare Function RegSetValueExA Lib "advapi32.dll" (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 Private Declare Function RegEnumKeyExA Lib "advapi32.dll" (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 Private Declare Function RegEnumValueA Lib "advapi32.dll" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long Private Declare Function RegQueryInfoKeyA Lib "advapi32.dll" (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 RegDeleteKeyA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpSubKey As String) As Long '************************************** '* Win 32 Base stubs, constants . . . '************************************** Private Const ERROR_SUCCESS As Long = 0 Private Const MAX_PATH As Long = 260 Private Const ERROR_NO_MORE_ITEMS As Long = 259& Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Long End Type Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type '*************************************** '* Errors raised from this module . . . '*************************************** Public Enum REGISTRY_ERROR_CODE CreateKeyFailed = vbObjectError + 512 CannotOpenKey CannotDetermineKeyDatatype CannotRetrieveKeyValue DatatypeNotSupported CannotCloseKey GetValueFailed SetValueFailed CannotDetermineKeyInfo CannotEnumerateKeyValue CannotEnumerateKey CannotDeleteKey End Enum '*************************************** '* Win32 Reserved Registry Handles . . . '*************************************** Public Enum WIN32_REG_ROOT_KEYS HKEY_CLASSES_ROOT = &H80000000 HKEY_CURRENT_USER = &H80000001 HKEY_LOCAL_MACHINE = &H80000002 HKEY_USERS = &H80000003 HKEY_PERFORMANCE_DATA = &H80000004 HKEY_CURRENT_CONFIG = &H80000005 HKEY_DYN_DATA = &H80000006 End Enum '************************************ '* Registry Open/Create Options . . . '************************************ Public Enum WIN32_REG_OPENCREATE_OPTIONS REG_OPTION_RESERVED = &H0 REG_OPTION_NON_VOLATILE = &H0 REG_OPTION_VOLATILE = &H1 REG_OPTION_CREATE_LINK = &H2 REG_OPTION_BACKUP_RESTORE = &H4 REG_OPTION_OPEN_LINK = &H8 End Enum '***************************************** '* Registry Specific Access Rights . . . '***************************************** Public Enum WIN32_REG_ACCESS_RIGHTS KEY_QUERY_VALUE = &H1 KEY_SET_VALUE = &H2 KEY_CREATE_SUB_KEY = &H4 KEY_ENUMERATE_SUB_KEYS = &H8 KEY_NOTIFY = &H10 KEY_CREATE_LINK = &H20 End Enum '*************************** '* Registry Datatype . . . '*************************** Public Enum WIN32_REG_DATATYPES REG_BINARY = 3 ' Free form binary REG_DWORD = 4 ' 32-bit number REG_DWORD_BIG_ENDIAN = 5 ' 32-bit number REG_DWORD_LITTLE_ENDIAN = 4 ' 32-bit number (same as REG_DWORD) REG_EXPAND_SZ = 2 ' Unicode null terminated string REG_LINK = 6 ' Symbolic Link (unicode) REG_MULTI_SZ = 7 ' Multiple Unicode strings REG_NONE = 0 ' No value type REG_RESOURCE_LIST = 8 ' Resource list in the resource map REG_SZ = 1 ' Unicode null terminated string End Enum '************************************************************************************************ '* Name Function RegCreateKey '* '* Author Mark Wilson '* '* Purpose Allow the caller to create a new key in the Registry '* '* Parameters --> eRoot WIN_32_REG_ROOT_KEYS One of the enumerated Root keys '* --> sSubKey STRING Treepath of new key '* -->[eOptions] WIN32_REG_OPENCREATE_OPTIONS Options for Key purpose '* -->[AccessRights] WIN32_REG_ACCESS_RIGHTS Bitfield for access purposes '* '* Returns HRESULT ERROR_SUCCESS on success, REGISTRY_ERROR_CODE on failure. '* '* Version 14/08/2001 Mark Wilson Created '* '************************************************************************************************ Public Function CreateKey(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, Optional ByVal eOptions As WIN32_REG_OPENCREATE_OPTIONS = 0&, Optional ByVal eAccessRights As WIN32_REG_ACCESS_RIGHTS = 63&) As Long On Error GoTo ERR_CreateKey Dim lRet As Long Dim lResult As Long Dim lDisposition As Long Dim lHRESULT As Long Dim uSA As SECURITY_ATTRIBUTES '*********************************** '* Attempt to Create the key . . . '*********************************** lRet = RegCreateKeyExA(eRoot, sSubkey, 0, "", eOptions, eAccessRights, uSA, lResult, lDisposition) If lRet <> ERROR_SUCCESS Then Err.Raise lRet End If '***************************************** '* Function completed successfully . . . '***************************************** CreateKey = ERROR_SUCCESS Exit Function ERR_CreateKey: CreateKey = REGISTRY_ERROR_CODE.CreateKeyFailed End Function '************************************************************************************************ '* Name Function GetValue '* '* Author Mark Wilson '* '* Purpose Retrieve the value of the specified key. This function '* processes all of the Win32 registry requirements '* '* Parameters --> eRoot WIN32_REG_ROOT_KEYS One of the enumerated root keys '* --> sSubKey STRING Treepath to the Key value '* --> szValue STRING The Value's name. '* <-> vValue vValue The Value's value. '* '* Returns HRESULT ERROR_SUCCESS on success. REGISTRY_ERROR_CODE on failure '* '* Version 14/08/2001 Mark Wilson Created '* '************************************************************************************************ Public Function GetValue(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, ByVal szValueName As String, vValue As Variant) As Long On Error GoTo ERR_GetRegValue Dim hKey As Long Dim lSize As Long Dim lRet As Long Dim vtValue As Variant Dim lType As Long Dim lValue As Long Dim sValue As String '***************************************** '* Open the key, to get it's handle . . . '***************************************** hKey = OpenKey(eRoot, sSubkey, , WIN32_REG_ACCESS_RIGHTS.KEY_QUERY_VALUE) If hKey = 0& Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If '********************************************* '* Determine the data-type of the value . . . '********************************************* lRet = RegQueryValueExA(hKey, szValueName, 0&, lType, ByVal 0&, lSize) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotDetermineKeyDatatype End If '************************************************ '* Branch processing depending on data-type . . . '************************************************ Select Case lType Case WIN32_REG_DATATYPES.REG_DWORD '****************************** '* Get the key's value . . . '****************************** lRet = RegQueryValueExA(hKey, szValueName, 0&, lType, lValue, lSize) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotRetrieveKeyValue End If vtValue = lValue Case WIN32_REG_DATATYPES.REG_SZ sValue = String(lSize, Chr(0)) '***************************** '* Get the key's value . . . '***************************** lRet = RegQueryValueExA(hKey, szValueName, 0&, lType, ByVal sValue, lSize) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotRetrieveKeyValue End If '******************************************* '* Tidy up NULL char at end of string . . . '******************************************* vtValue = Left(sValue, lSize - 1) Case Else '****************************************************** '* Other datatypes at this time are not supported . . . '****************************************************** Err.Raise REGISTRY_ERROR_CODE.DatatypeNotSupported End Select '************************* '* Clear up handles . . . '************************* lRet = RegCloseKey(hKey) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotCloseKey End If '**************************** '* Asssign and return . . . '**************************** vValue = vtValue GetValue = ERROR_SUCCESS Exit Function ERR_GetRegValue: GetValue = Err.Number Call RegCloseKey(hKey) vtValue = vbEmpty End Function '************************************************************************************************ '* Name Function SetValue '* '* Author Mark Wilson '* '* Purpose Set the Registry Value. '* This function will create the subkey\value if it does not already exist. '* '* Parameters --> eRoot WIN32_REG_ROOT_KEYS One of the enumerated root keys '* --> sSubKey STRING Treepath to the Key value '* --> szValuename STRING The Value's name '* --> eType WIN32_REG_DATATYPES The datatype of the key value. '* --> vValue VARIANT The value itself. '* '* '* Returns HRESULT ERROR_SUCCESS on success, REGISTRY_ERROR_CODE on failure '* '* Version 14/08/2001 Mark Wilson Created '* '************************************************************************************************ Public Function SetValue(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, ByVal szValueName As String, ByVal eDatatype As WIN32_REG_DATATYPES, ByVal vValue As Variant) As Long On Error GoTo ERR_SetRegValue Dim hKey As Long Dim lRet As Long '******************************************* '* Open, and retrieve handle to key . . . '******************************************* hKey = OpenKey(eRoot, sSubkey, , KEY_SET_VALUE) If hKey = 0& Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If '********************************************* '* Prepare buffer depending on datatype . . . '********************************************* Select Case eDatatype Case WIN32_REG_DATATYPES.REG_DWORD lRet = RegSetValueExA(hKey, szValueName, 0&, eDatatype, CLng(vValue), 4) Case WIN32_REG_DATATYPES.REG_SZ lRet = RegSetValueExA(hKey, szValueName, 0&, eDatatype, ByVal CStr(vValue), Len(vValue)) Case Else Err.Raise REGISTRY_ERROR_CODE.DatatypeNotSupported End Select If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.SetValueFailed End If '****************** '* Clean up . . . '****************** lRet = RegCloseKey(hKey) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotCloseKey End If SetValue = ERROR_SUCCESS Exit Function ERR_SetRegValue: SetValue = Err.Number Call RegCloseKey(hKey) End Function '************************************************************************************************ '* Name Function OpenKey '* '* Author Mark Wilson '* '* Purpose Opens the specified registry key. '* '* Parameters --> eRoot RESERVED_KEYS One of the enumerated root keys '* --> sSubKey STRING Treepath to the Key value '* -->[eOptions] WIN32_REG_OPENCREATE_OPTIONS Options for key opening. '* -->[AccessRights] WIN32_REG_ACCESS_RIGHTS Bitfield for Access purposes '* '* Returns LONG A handle to Key. Will return zero on error. '* '* Version 06/08/2001 Mark Wilson Created '* '************************************************************************************************ Private Function OpenKey(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, Optional eOptions As WIN32_REG_OPENCREATE_OPTIONS = &H0, Optional ByVal AccessRights As WIN32_REG_ACCESS_RIGHTS = &H34) As Long On Error GoTo ERR_OpenKey Dim lRet As Long Dim lResult As Long '***************************** '* Open an existing key . . . '***************************** lRet = RegOpenKeyExA(eRoot, sSubkey, eOptions, AccessRights, lResult) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If OpenKey = lResult Exit Function ERR_OpenKey: OpenKey = 0& End Function '************************************************************************************************ '* Name Function RegEnumValues '* '* Author Mark Wilson '* '* Purpose Enumerates the values in the registry for the specified subkey. '* '* Parameters --> eRoot RESERVED_KEYS One of the enumerated root keys '* --> sSubKey STRING Treepath to the Key value '* <-> EnumValues VARIANT Placeholder for outcome of function. '* Returns vbNull on error, or an array of '* values. '* '* Returns LONG ERROR_SUCCESS on success, REGISTRY_ERROR_CODE on failure '* '* Version 25/09/2001 Mark Wilson Created '* '************************************************************************************************ Public Function RegEnumValues(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, ByRef EnumValues As Variant) As Long On Error GoTo ERR_EnumerateValues Dim lRet As Long Dim hKey As Long Dim lCtr As Long Dim sName As String * MAX_PATH Dim uFiletime As FILETIME Dim lValueCount As Long Dim lMaxValueLen As Long Dim sValueName As String Dim Values() As String Dim bData() As Byte lCtr = 0 '****************************** '* Open the specified key . . . '****************************** hKey = OpenKey(HKEY_LOCAL_MACHINE, sSubkey, , KEY_QUERY_VALUE) If hKey = 0 Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If '*********************************************** '* Get the count of values in this subkey . . . '*********************************************** lRet = RegQueryInfoKeyA(hKey, vbNullString, 0&, 0&, 0&, 0&, 0&, lValueCount, lMaxValueLen, 0&, 0&, uFiletime) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotDetermineKeyInfo End If '*************************** '* Alloc memory . . . '*************************** ReDim Values(lValueCount - 1) ReDim bData(256) '************************** '* Get the values out . . . '************************** For lCtr = 0 To lValueCount - 1 sValueName = String(lMaxValueLen + 1, " ") lRet = RegEnumValueA(hKey, lCtr, sValueName, Len(sValueName), 0&, 0&, bData(0), UBound(bData)) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotEnumerateKeyValue End If Values(lCtr) = Trim(sValueName) Next '********************************** '* Return the relevant stuff . . . '********************************** EnumValues = Values RegEnumValues = ERROR_SUCCESS Erase Values Exit Function ERR_EnumerateValues: Call RegCloseKey(hKey) EnumValues = Null RegEnumValues = Err.Number Erase Values End Function '************************************************************************************************ '* Name Function RegEnumKeys '* '* Author Mark Wilson '* '* Purpose Enumerates the keys in the registry for the specified subkey. '* '* Parameters --> eRoot RESERVED_KEYS One of the enumerated root keys '* --> sSubKey STRING Treepath to the Key value '* <-> EnumKeys VARIANT Placeholder for outcome of function. '* Returns NULL on error, or an array of '* values. '* '* Returns LONG ERROR_SUCCESS on success, REGISTRY_ERROR_CODE on failure '* '* Version 26/09/2001 Mark Wilson Created '* '************************************************************************************************ Public Function RegEnumKeys(ByVal eRoot As WIN32_REG_ROOT_KEYS, ByVal sSubkey As String, ByRef EnumKeys As Variant) As Long On Error GoTo ERR_EnumRegKeys Dim lRet As Long Dim lCtr As Long Dim hKey As Long Dim lKeyCount As Long Dim lKeyLen As Long Dim sKeyName As String Dim uFiletime As FILETIME Dim Keys() As String '********************************************* '* Open the specified key in query mode . . . '********************************************* hKey = OpenKey(HKEY_LOCAL_MACHINE, sSubkey, , KEY_QUERY_VALUE) If hKey = 0 Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If '********************************************************** '* Get the amount of keys, and maximum length of keys . . . '********************************************************** lRet = RegQueryInfoKeyA(hKey, vbNullString, 0&, 0&, lKeyCount, lKeyLen, 0&, 0&, 0&, 0&, 0&, uFiletime) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotDetermineKeyInfo End If Call RegCloseKey(hKey) '************************************* '* Open key for enumeration mode . . . '************************************* hKey = OpenKey(HKEY_LOCAL_MACHINE, sSubkey, , KEY_ENUMERATE_SUB_KEYS) If hKey = 0 Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If ReDim Keys(lKeyCount) '************************************************ '* Cycle through all keys, adding to array . . . '************************************************ For lCtr = 0 To lKeyCount - 1 sKeyName = String(lKeyLen + 1, " ") lRet = RegEnumKeyExA(hKey, lCtr, sKeyName, Len(sKeyName), 0&, vbNullString, 0&, uFiletime) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotEnumerateKey End If Keys(lCtr) = Trim(sKeyName) Next EnumKeys = Keys RegEnumKeys = ERROR_SUCCESS Erase Keys Exit Function ERR_EnumRegKeys: Call RegCloseKey(hKey) EnumKeys = Null RegEnumKeys = Err.Number Erase Keys End Function '************************************************************************************************ '* Name Function RegDeleteKey '* '* Author Mark Wilson '* '* Purpose Deletes a registry key '* '* Parameters --> sPath STRING The path to the key '* --> sKey STRING The key to be deleted '* '* Returns LONG ERROR_SUCCESS on success, REGISTRY_ERROR_CODE on failure '* '* If the key has sub-keys then these are deleted as well. '* This function only works for subkeys under HKEY_LOCAL_MACHINE '* '* Version 12/03/2002 Mark Wilson Created '* '************************************************************************************************ Public Function RegDeleteKey(ByVal sPath As String) As Long On Error GoTo ERR_RegDeleteKey Dim lRet As Long Dim hKey As Long '*************************************** '* Open the key to get it's handle . . . '*************************************** hKey = OpenKey(HKEY_LOCAL_MACHINE, sPath) If hKey = ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotOpenKey End If '********************** '* Delete the key . . . '********************** lRet = RegDeleteKeyA(WIN32_REG_ROOT_KEYS.HKEY_LOCAL_MACHINE, sPath) If lRet <> ERROR_SUCCESS Then Err.Raise REGISTRY_ERROR_CODE.CannotDeleteKey End If RegDeleteKey = ERROR_SUCCESS Exit Function ERR_RegDeleteKey: RegDeleteKey = Err.Number End Function