Private 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_EXECUTE = KEY_READ
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult 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, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition 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, lpData As Byte, lpcbData As Long) As Long Private Declare Function RegEnumKeyEx 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 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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData 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, lpData As Long, ByVal cbData 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, ByRef lpData As Long, ByVal cbData As Long) As Long Private Declare Function RegQueryValueEx 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 ' Note that if you declare the lpData parameter as String, you must pass it By Value. Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long Private Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long Private Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hKey As Long, ByVal lpFile As String, ByVal dwflags As Long) As Long
Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type
Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDescriptor As Long bInheritHandle As Boolean End Type
Public Function GetValue(ByVal mainKey As enumRegMainKey, _ ByVal subKey As String, _ ByVal keyV As String, _ ByRef sValue As Variant, _ Optional ByRef rlngErrNum As Long, _ Optional ByRef rstrErrDescr As String) As Boolean
Dim hKey As Long, lType As Long, lBuffer As Long, sBuffer As String, lData As Long On Error GoTo GetValueErr GetValue = False
If RegOpenKeyEx(mainKey, subKey, 0, KEY_READ, hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If
If RegQueryValueEx(hKey, keyV, 0, lType, ByVal 0, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If
Select Case lType Case iREG_SZ lBuffer = 255 sBuffer = Space(lBuffer) If RegQueryValueEx(hKey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
Case iREG_EXPAND_SZ sBuffer = Space(lBuffer) If RegQueryValueEx(hKey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
Case iREG_DWORD If RegQueryValueEx(hKey, keyV, 0, lType, lData, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If sValue = lData
Case iREG_BINARY If RegQueryValueEx(hKey, keyV, 0, lType, lData, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If sValue = lData
End Select
If RegCloseKey(hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "获取注册表值时出错" End If
Public Function SetValue(ByVal mainKey As enumRegMainKey, _ ByVal subKey As String, _ ByVal keyV As String, _ ByVal lType As enumRegSzType, _ ByVal sValue As Variant, _ Optional ByRef rlngErrNum As Long, _ Optional ByRef rstrErrDescr As String) As Boolean
Dim S As Long, lBuffer As Long, hKey As Long Dim ss As SECURITY_ATTRIBUTES On Error GoTo SetValueErr SetValue = False
ss.nLength = Len(ss) ss.lpSecurityDescriptor = 0 ss.bInheritHandle = True If RegCreateKeyEx(mainKey, subKey, 0, "", 0, KEY_WRITE, ss, hKey, S) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Select Case lType Case iREG_SZ lBuffer = LenB(sValue) If RegSetValueEx(hKey, keyV, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Case iREG_EXPAND_SZ lBuffer = LenB(sValue) If RegSetValueEx(hKey, keyV, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Case iREG_DWORD lBuffer = 4 If RegSetValueExA(hKey, keyV, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Case iREG_BINARY lBuffer = 4 If RegSetValueExA(hKey, keyV, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Case Else Err.Raise vbObjectError + 1, , "不支持该参数类型"
End Select
If RegCloseKey(hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "设置注册表时出错" End If
Public Function DeleteValue(ByVal mainKey As enumRegMainKey, _ ByVal subKey As String, _ ByVal keyV As String, _ Optional ByRef rlngErrNum As Long, _ Optional ByRef rstrErrDescr As String) As Boolean Dim hKey As Long
On Error GoTo DeleteValueErr DeleteValue = False
If RegOpenKeyEx(mainKey, subKey, 0, KEY_WRITE, hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If
If RegDeleteValue(hKey, keyV) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If
If RegCloseKey(hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If
Public Function DeleteKey(ByVal mainKey As enumRegMainKey, _ ByVal subKey As String, _ ByVal keyV As String, _ Optional ByRef rlngErrNum As Long, _ Optional ByRef rstrErrDescr As String) As Boolean
Dim hKey As Long
On Error GoTo DeleteKeyErr DeleteKey = False
If RegOpenKeyEx(mainKey, subKey, 0, KEY_WRITE, hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If
If RegDeleteKey(hKey, keyV) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If
If RegCloseKey(hKey) <> ERROR_SUCCESS Then Err.Raise vbObjectError + 1, , "删除注册表值时出错" End If