用户登陆
站点日历
站点统计
最新评论
VB三个注册表操作模块(都来自网络) [ 日期：2008-02-22 ] [ 来自：VB三个注册表操作模块(都来自网络)
Option Explicit
Global InFo
Global G
Global allcharacters
Global molestate()
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx 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 RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
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
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
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte
Const DisplayErrorMsg = False
Function SetDWORDValue(SubKey As String, entry As String, Value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, entry, 0, REG_DWORD, Value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetDWORDValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegQueryValueExA(hKey, entry, 0, REG_DWORD, lBuffer, 4) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetDWORDValue = lBuffer 'return the value
Else 'otherwise, if the value couldnt be retreived
GetDWORDValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
Else 'otherwise, if the key couldnt be opened
GetDWORDValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
End If
End Function
Function SetBinaryValue(SubKey As String, entry As String, Value As String)
Dim i
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
lDataSize = Len(Value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Value, i, 1))
Next
rtn = RegSetValueExB(hKey, entry, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetBinaryValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened
lBufferSize = 1
rtn = RegQueryValueEx(hKey, entry, 0, REG_BINARY, 0, lBufferSize) 'get the value from the registry
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, entry, 0, REG_BINARY, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetBinaryValue = sBuffer 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetBinaryValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
Else 'otherwise, if the key couldnt be opened
GetBinaryValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
End If
End Function
Function DeleteKey(KeyName As String)
Call ParseKey(KeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, KeyName, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegDeleteKey(hKey, KeyName) 'delete the key
rtn = RegCloseKey(hKey) 'close the key
End If
End If
End Function
Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function
Function ErrorMsg(lErrorCode As Long) As String
Dim GetErrorMsg
'If an error does accurr, and the user wants error messages displayed, then
'display one of the following error messages
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & str$(lErrorCode)
End Select
End Function
Function GetStringValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
sBuffer = Space(255) 'make a buffer
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, entry, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetStringValue = "Error" 'return Error to the user (Don't remove the "Error" and change it into "" because it's needed.)
If DisplayErrorMsg = True Then 'if the user wants errors displayed then
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
Else 'otherwise, if the key couldnt be opened
GetStringValue = "Error" 'return Error to the user (Don't remove the "Error" and change it into "" because it's needed.)
If DisplayErrorMsg = True Then 'if the user wants errors displayed then
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
End If
End Function
Private Sub ParseKey(KeyName As String, Keyhandle As Long)
rtn = InStr(KeyName, "\") 'return if "\" is contained in the Keyname
If Left(KeyName, 5) <> "HKEY_" Or Right(KeyName, 1) = "\" Then 'if the is a "\" at the end of the Keyname then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + KeyName 'display error to the user
Exit Sub 'exit the procedure
ElseIf rtn = 0 Then 'if the Keyname contains no "\"
Keyhandle = GetMainKeyHandle(KeyName)
KeyName = "" 'leave Keyname blank
Else 'otherwise, Keyname contains "\"
Keyhandle = GetMainKeyHandle(Left(KeyName, rtn - 1)) 'seperate the Keyname
KeyName = Right(KeyName, Len(KeyName) - rtn)
End If
End Sub
Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey) 'create the key
If rtn = ERROR_SUCCESS Then 'if the key was created then
rtn = RegCloseKey(hKey) 'close the key
End If
End If
End Function
Function SetStringValue(SubKey As String, entry As String, Value As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
rtn = RegSetValueEx(hKey, entry, 0, REG_SZ, ByVal Value, Len(Value)) 'write the value
If Not rtn = ERROR_SUCCESS Then 'if there was an error writting the value
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Global InFo
Global G
Global allcharacters
Global molestate()
Type FILETIME
lLowDateTime As Long
lHighDateTime As Long
End Type
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Declare Function RegQueryValueEx 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 RegQueryValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByRef lpData As Long, lpcbData As Long) As Long
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
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
Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_OUTOFMEMORY = 14&
Const ERROR_INVALID_PARAMETER = 87&
Const ERROR_ACCESS_DENIED = 5&
Const ERROR_NO_MORE_ITEMS = 259&
Const ERROR_MORE_DATA = 234&
Const REG_NONE = 0&
Const REG_SZ = 1&
Const REG_EXPAND_SZ = 2&
Const REG_BINARY = 3&
Const REG_DWORD = 4&
Const REG_DWORD_LITTLE_ENDIAN = 4&
Const REG_DWORD_BIG_ENDIAN = 5&
Const REG_LINK = 6&
Const REG_MULTI_SZ = 7&
Const REG_RESOURCE_LIST = 8&
Const REG_FULL_RESOURCE_DESCRIPTOR = 9&
Const REG_RESOURCE_REQUIREMENTS_LIST = 10&
Const KEY_QUERY_VALUE = &H1&
Const KEY_SET_VALUE = &H2&
Const KEY_CREATE_SUB_KEY = &H4&
Const KEY_ENUMERATE_SUB_KEYS = &H8&
Const KEY_NOTIFY = &H10&
Const KEY_CREATE_LINK = &H20&
Const READ_CONTROL = &H20000
Const WRITE_DAC = &H40000
Const WRITE_OWNER = &H80000
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_READ = READ_CONTROL
Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Const KEY_EXECUTE = KEY_READ
Dim hKey As Long, MainKeyHandle As Long
Dim rtn As Long, lBuffer As Long, sBuffer As String
Dim lBufferSize As Long
Dim lDataSize As Long
Dim ByteArray() As Byte
Const DisplayErrorMsg = False
Function SetDWORDValue(SubKey As String, entry As String, Value As Long)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then
rtn = RegSetValueExA(hKey, entry, 0, REG_DWORD, Value, 4)
If Not rtn = ERROR_SUCCESS Then
If DisplayErrorMsg = True Then
MsgBox ErrorMsg(rtn)
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetDWORDValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegQueryValueExA(hKey, entry, 0, REG_DWORD, lBuffer, 4) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetDWORDValue = lBuffer 'return the value
Else 'otherwise, if the value couldnt be retreived
GetDWORDValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
Else 'otherwise, if the key couldnt be opened
GetDWORDValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
End If
End Function
Function SetBinaryValue(SubKey As String, entry As String, Value As String)
Dim i
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
lDataSize = Len(Value)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(Value, i, 1))
Next
rtn = RegSetValueExB(hKey, entry, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
If DisplayErrorMsg = True Then 'if the user want errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
Function GetBinaryValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened
lBufferSize = 1
rtn = RegQueryValueEx(hKey, entry, 0, REG_BINARY, 0, lBufferSize) 'get the value from the registry
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, entry, 0, REG_BINARY, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
GetBinaryValue = sBuffer 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetBinaryValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
Else 'otherwise, if the key couldnt be opened
GetBinaryValue = "Error" 'return Error to the user
If DisplayErrorMsg = True Then 'if the user wants to errors displayed
MsgBox ErrorMsg(rtn) 'display the error to the user
End If
End If
End If
End Function
Function DeleteKey(KeyName As String)
Call ParseKey(KeyName, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, KeyName, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegDeleteKey(hKey, KeyName) 'delete the key
rtn = RegCloseKey(hKey) 'close the key
End If
End If
End Function
Function GetMainKeyHandle(MainKeyName As String) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Select Case MainKeyName
Case "HKEY_CLASSES_ROOT"
GetMainKeyHandle = HKEY_CLASSES_ROOT
Case "HKEY_CURRENT_USER"
GetMainKeyHandle = HKEY_CURRENT_USER
Case "HKEY_LOCAL_MACHINE"
GetMainKeyHandle = HKEY_LOCAL_MACHINE
Case "HKEY_USERS"
GetMainKeyHandle = HKEY_USERS
Case "HKEY_PERFORMANCE_DATA"
GetMainKeyHandle = HKEY_PERFORMANCE_DATA
Case "HKEY_CURRENT_CONFIG"
GetMainKeyHandle = HKEY_CURRENT_CONFIG
Case "HKEY_DYN_DATA"
GetMainKeyHandle = HKEY_DYN_DATA
End Select
End Function
Function ErrorMsg(lErrorCode As Long) As String
Dim GetErrorMsg
'If an error does accurr, and the user wants error messages displayed, then
'display one of the following error messages
Select Case lErrorCode
Case 1009, 1015
GetErrorMsg = "The Registry Database is corrupt!"
Case 2, 1010
GetErrorMsg = "Bad Key Name"
Case 1011
GetErrorMsg = "Can't Open Key"
Case 4, 1012
GetErrorMsg = "Can't Read Key"
Case 5
GetErrorMsg = "Access to this key is denied"
Case 1013
GetErrorMsg = "Can't Write Key"
Case 8, 14
GetErrorMsg = "Out of memory"
Case 87
GetErrorMsg = "Invalid Parameter"
Case 234
GetErrorMsg = "There is more data than the buffer has been allocated to hold."
Case Else
GetErrorMsg = "Undefined Error Code: " & str$(lErrorCode)
End Select
End Function
Function GetStringValue(SubKey As String, entry As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_READ, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
sBuffer = Space(255) 'make a buffer
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, entry, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
If rtn = ERROR_SUCCESS Then 'if the value could be retreived then
rtn = RegCloseKey(hKey) 'close the key
sBuffer = Trim(sBuffer)
GetStringValue = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user
Else 'otherwise, if the value couldnt be retreived
GetStringValue = "Error" 'return Error to the user (Don't remove the "Error" and change it into "" because it's needed.)
If DisplayErrorMsg = True Then 'if the user wants errors displayed then
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
Else 'otherwise, if the key couldnt be opened
GetStringValue = "Error" 'return Error to the user (Don't remove the "Error" and change it into "" because it's needed.)
If DisplayErrorMsg = True Then 'if the user wants errors displayed then
MsgBox ErrorMsg(rtn) 'tell the user what was wrong
End If
End If
End If
End Function
Private Sub ParseKey(KeyName As String, Keyhandle As Long)
rtn = InStr(KeyName, "\") 'return if "\" is contained in the Keyname
If Left(KeyName, 5) <> "HKEY_" Or Right(KeyName, 1) = "\" Then 'if the is a "\" at the end of the Keyname then
MsgBox "Incorrect Format:" + Chr(10) + Chr(10) + KeyName 'display error to the user
Exit Sub 'exit the procedure
ElseIf rtn = 0 Then 'if the Keyname contains no "\"
Keyhandle = GetMainKeyHandle(KeyName)
KeyName = "" 'leave Keyname blank
Else 'otherwise, Keyname contains "\"
Keyhandle = GetMainKeyHandle(Left(KeyName, rtn - 1)) 'seperate the Keyname
KeyName = Right(KeyName, Len(KeyName) - rtn)
End If
End Sub
Function CreateKey(SubKey As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegCreateKey(MainKeyHandle, SubKey, hKey) 'create the key
If rtn = ERROR_SUCCESS Then 'if the key was created then
rtn = RegCloseKey(hKey) 'close the key
End If
End If
End Function
Function SetStringValue(SubKey As String, entry As String, Value As String)
Call ParseKey(SubKey, MainKeyHandle)
If MainKeyHandle Then
rtn = RegOpenKeyEx(MainKeyHandle, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key was open successfully then
rtn = RegSetValueEx(hKey, entry, 0, REG_SZ, ByVal Value, Len(Value)) 'write the value
If Not rtn = ERROR_SUCCESS Then 'if there was an error writting the value
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
rtn = RegCloseKey(hKey) 'close the key
Else 'if there was an error opening the key
If DisplayErrorMsg = True Then 'if the user wants errors displayed
MsgBox ErrorMsg(rtn) 'display the error
End If
End If
End If
End Function
|
|
'**模 块 名：RegWork
'**创 建 人：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**描 述：注册表操作(不同类型,读写方法有一定区别)
'**版 本：版本1.0
'*************************************************************************
'---------------------------------------------------------------
'-注册表 API 声明...
'---------------------------------------------------------------
'关闭登录关键字
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'建立关键字
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" 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, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
'打开关键字
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
'返回关键字的类型和值
Private Declare Function RegQueryValueEx_SZ Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueEx_DWORD 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
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, ByRef lpcbData As Long) As Long
'将文本字符串与指定关键字关联
Private Declare Function RegSetValueEx_SZ Lib "advapi32" 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 RegSetValueEx_DWORD Lib "advapi32" 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 RegSetValueEx_BINARY 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
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
'删除关键字
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'从登录关键字中删除一个值
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'---------------------------------------------------------------
'- 注册表 Api 常数...
'---------------------------------------------------------------
' 注册表的数据类型
Public Enum REGValueType
[REG_SZ] = 1 ' Unicode空终结字符串
[REG_EXPAND_SZ] = 2 ' Unicode空终结字符串
[REG_BINARY] = 3 ' 二进制数值
[REG_DWORD] = 4 ' 32-bit 数字
[REG_DWORD_BIG_ENDIAN] = 5
[REG_LINK] = 6
[REG_MULTI_SZ] = 7 ' 二进制数值串
End Enum
' 注册表创建类型值...
Const REG_OPTION_NON_VOLATILE = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' 注册表关键字根类型...
Public Enum REGRoot
[HKEY_CLASSES_ROOT] = &H80000000
[HKEY_CURRENT_USER] = &H80000001
[HKEY_LOCAL_MACHINE] = &H80000002
[HKEY_USERS] = &H80000003
[HKEY_PERFORMANCE_DATA] = &H80000004
End Enum
' 返回值...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
'---------------------------------------------------------------
'- 注册表安全属性类型...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
'*************************************************************************
'**函 数 名：WriteRegKey
'**输 入：ByVal KeyRoot(REGRoot) - 根
'** ：ByVal KeyName(String) - 键的路径
'** ：ByVal SubKeyName(String) - 键名
'** ：ByVal SubKeyType(REGValueType) - 键的类型
'** ：ByVal SubKeyValue(String) - 键值
'**输 出：(Boolean) - 成功返回True，失败返回False
'**功能描述：写注册表
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月10日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function WriteRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String, ByVal SubKeyType As REGValueType, ByVal SubKeyValue As String) As Boolean
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理一个注册表关键字
Dim hDepth As Long '
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
Dim i As Integer
Dim bytValue(1024) As Byte
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
'------------------------------------------------------------
'- 创建/打开注册表关键字...
'------------------------------------------------------------
rc = RegCreateKeyEx(KeyRoot, KeyName, 0, SubKeyType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, hDepth)
' 创建/打开//KeyRoot//KeyName
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理...
'------------------------------------------------------------
'- 创建/修改关键字值...
'------------------------------------------------------------
If (SubKeyValue = "") Then SubKeyValue = " " ' 要让RegSetValueEx() 工作需要输入一个空格...
Select Case SubKeyType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据
类型
'------------------------------------------------------------------
rc = RegSetValueEx_SZ(hKey, SubKeyName, 0, SubKeyType, ByVal SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'------------------------------------------------------------------
Case REG_DWORD ' 四字节注册表关键字数据
类型
'-------------------------------------------------------------------
rc = RegSetValueEx_DWORD(hKey, SubKeyName, 0, SubKeyType, Val("&h" + SubKeyValue), 4)
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'-------------------------------------------------------------------
Case REG_BINARY ' 二进制字符串
'-------------------------------------------------------------------
Dim intNum As Integer
intNum = 0
For i = 1 To Len(Trim(SubKeyValue)) - 1 Step 3
intNum = intNum + 1
bytValue(intNum - 1) = Val("&h" + Mid(SubKeyValue, i, 2))
Next i
rc = RegSetValueEx_BINARY(hKey, SubKeyName, 0, SubKeyType, bytValue(0), intNum)
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'-------------------------------------------------------------------
Case Else
'--------------------------------------------------------------------
GoTo CreateKeyError ' 错误处理
'--------------------------------------------------------------------
End Select
'- 关闭注册表关键字...
'------------------------------------------------------------
rc = RegCloseKey(hKey) ' 关闭关键字
WriteRegKey = True ' 返回成功
Exit Function ' 退出
'-------------------------------------------------------------------------------------
CreateKeyError:
WriteRegKey = False ' 设置错误返回代码
rc = RegCloseKey(hKey) ' 试图关闭关键字
End Function
'*************************************************************************
'**函 数 名：ReadRegKey
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(String) - 返回键值
'**功能描述：读注册表
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月10日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function ReadRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByValSubKeyName As String) As String
Dim i As Long ' 循环计数器
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理打开的注册表关键字
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' 注册表关键字数据类型
Dim tmpVal As String ' 注册表关键字的临时存储器
Dim KeyValSize As Long ' 注册表关键字变量尺寸
Dim lngValue As Long
Dim bytValue(1024) As Byte
'------------------------------------------------------------
' 在 KeyRoot下打开注册表关键字
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册表关键字
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
'------------------------------------------------------------
' 检测键的类型
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyName, 0, lKeyValType, ByVal 0, KeyValSize)
' 获得/创建关键字的值
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
'------------------------------------------------------------
'读相应的键值
'------------------------------------------------------------
Select Case lKeyValType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据
类型
'--------------------------------
tmpVal = String$(1024, 0) ' 分配变量空间
KeyValSize = 1024 ' 标记变量尺寸
rc = RegQueryValueEx_SZ(hKey, SubKeyName, 0, 0, tmpVal, KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
If InStr(tmpVal, Chr(0)) > 0 Then sKeyVal = Left(tmpVal, InStr(tmpVal, Chr(0)) - 1) ' 复制字符串的值
'--------------------------------
Case REG_DWORD ' 四字节注册表关键字数
据类型
'--------------------------------
KeyValSize = 1024 ' 标记变量尺寸
rc = RegQueryValueEx_DWORD(hKey, SubKeyName, 0, 0, lngValue, KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = "0x" + Hex(lngValue)
'--------------------------------
Case REG_BINARY ' 二进制字符串
'--------------------------------
rc = RegQueryValueEx(hKey, SubKeyName, 0, 0, bytValue(0), KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = ""
For i = 1 To KeyValSize
If Len(Hex$(bytValue(i - 1))) = 1 Then
sKeyVal = sKeyVal + "0" + Hex(bytValue(i - 1)) + " "
Else
sKeyVal = sKeyVal + Hex(bytValue(i - 1)) + " "
End If
Next i
'--------------------------------
Case Else
'--------------------------------
sKeyVal = ""
'--------------------------------
End Select
'----------------------------------------
ReadRegKey = sKeyVal ' 返回值
rc = RegCloseKey(hKey) ' 关闭注册表关键字
Exit Function ' 退出
'-----------------------------------------------------------------------------------------
GetKeyError: ' 错误发生过后进行清除...
ReadRegKey = "" ' 设置返回值为错误
rc = RegCloseKey(hKey) ' 关闭注册表关键字
End Function
'*************************************************************************
'**函 数 名：DelRegKey
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(Long) - 状态码
'**功能描述：删除关键字
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function DelRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
DelRegKey = 0 ' 假定成功
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegKey = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'删除关键字
DelRegKey = RegDeleteKey(lKeyId, ByVal SubKeyName)
End If
End Function
'*************************************************************************
'**函 数 名：DelRegValue
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(Long) - 状态码
'**功能描述：从登录关键字中删除一个值
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function DelRegValue(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
DelRegValue = 0 ' 假定成功
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegValue = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'从登录关键字中删除一个值
DelRegValue = RegDeleteValue(lKeyId, ByVal SubKeyName)
End If
End Function
'**创 建 人：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**描 述：注册表操作(不同类型,读写方法有一定区别)
'**版 本：版本1.0
'*************************************************************************
'---------------------------------------------------------------
'-注册表 API 声明...
'---------------------------------------------------------------
'关闭登录关键字
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'建立关键字
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" 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, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
'打开关键字
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
'返回关键字的类型和值
Private Declare Function RegQueryValueEx_SZ Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegQueryValueEx_DWORD 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
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, ByRef lpcbData As Long) As Long
'将文本字符串与指定关键字关联
Private Declare Function RegSetValueEx_SZ Lib "advapi32" 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 RegSetValueEx_DWORD Lib "advapi32" 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 RegSetValueEx_BINARY 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
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName As Long) As Long
'删除关键字
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'从登录关键字中删除一个值
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'---------------------------------------------------------------
'- 注册表 Api 常数...
'---------------------------------------------------------------
' 注册表的数据类型
Public Enum REGValueType
[REG_SZ] = 1 ' Unicode空终结字符串
[REG_EXPAND_SZ] = 2 ' Unicode空终结字符串
[REG_BINARY] = 3 ' 二进制数值
[REG_DWORD] = 4 ' 32-bit 数字
[REG_DWORD_BIG_ENDIAN] = 5
[REG_LINK] = 6
[REG_MULTI_SZ] = 7 ' 二进制数值串
End Enum
' 注册表创建类型值...
Const REG_OPTION_NON_VOLATILE = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' 注册表关键字根类型...
Public Enum REGRoot
[HKEY_CLASSES_ROOT] = &H80000000
[HKEY_CURRENT_USER] = &H80000001
[HKEY_LOCAL_MACHINE] = &H80000002
[HKEY_USERS] = &H80000003
[HKEY_PERFORMANCE_DATA] = &H80000004
End Enum
' 返回值...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
'---------------------------------------------------------------
'- 注册表安全属性类型...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
'*************************************************************************
'**函 数 名：WriteRegKey
'**输 入：ByVal KeyRoot(REGRoot) - 根
'** ：ByVal KeyName(String) - 键的路径
'** ：ByVal SubKeyName(String) - 键名
'** ：ByVal SubKeyType(REGValueType) - 键的类型
'** ：ByVal SubKeyValue(String) - 键值
'**输 出：(Boolean) - 成功返回True，失败返回False
'**功能描述：写注册表
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月10日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function WriteRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String, ByVal SubKeyType As REGValueType, ByVal SubKeyValue As String) As Boolean
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理一个注册表关键字
Dim hDepth As Long '
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
Dim i As Integer
Dim bytValue(1024) As Byte
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
'------------------------------------------------------------
'- 创建/打开注册表关键字...
'------------------------------------------------------------
rc = RegCreateKeyEx(KeyRoot, KeyName, 0, SubKeyType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, hDepth)
' 创建/打开//KeyRoot//KeyName
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理...
'------------------------------------------------------------
'- 创建/修改关键字值...
'------------------------------------------------------------
If (SubKeyValue = "") Then SubKeyValue = " " ' 要让RegSetValueEx() 工作需要输入一个空格...
Select Case SubKeyType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据
类型
'------------------------------------------------------------------
rc = RegSetValueEx_SZ(hKey, SubKeyName, 0, SubKeyType, ByVal SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'------------------------------------------------------------------
Case REG_DWORD ' 四字节注册表关键字数据
类型
'-------------------------------------------------------------------
rc = RegSetValueEx_DWORD(hKey, SubKeyName, 0, SubKeyType, Val("&h" + SubKeyValue), 4)
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'-------------------------------------------------------------------
Case REG_BINARY ' 二进制字符串
'-------------------------------------------------------------------
Dim intNum As Integer
intNum = 0
For i = 1 To Len(Trim(SubKeyValue)) - 1 Step 3
intNum = intNum + 1
bytValue(intNum - 1) = Val("&h" + Mid(SubKeyValue, i, 2))
Next i
rc = RegSetValueEx_BINARY(hKey, SubKeyName, 0, SubKeyType, bytValue(0), intNum)
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
'-------------------------------------------------------------------
Case Else
'--------------------------------------------------------------------
GoTo CreateKeyError ' 错误处理
'--------------------------------------------------------------------
End Select
'- 关闭注册表关键字...
'------------------------------------------------------------
rc = RegCloseKey(hKey) ' 关闭关键字
WriteRegKey = True ' 返回成功
Exit Function ' 退出
'-------------------------------------------------------------------------------------
CreateKeyError:
WriteRegKey = False ' 设置错误返回代码
rc = RegCloseKey(hKey) ' 试图关闭关键字
End Function
'*************************************************************************
'**函 数 名：ReadRegKey
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(String) - 返回键值
'**功能描述：读注册表
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月10日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function ReadRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByValSubKeyName As String) As String
Dim i As Long ' 循环计数器
Dim rc As Long ' 返回代码
Dim hKey As Long ' 处理打开的注册表关键字
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' 注册表关键字数据类型
Dim tmpVal As String ' 注册表关键字的临时存储器
Dim KeyValSize As Long ' 注册表关键字变量尺寸
Dim lngValue As Long
Dim bytValue(1024) As Byte
'------------------------------------------------------------
' 在 KeyRoot下打开注册表关键字
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册表关键字
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
'------------------------------------------------------------
' 检测键的类型
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyName, 0, lKeyValType, ByVal 0, KeyValSize)
' 获得/创建关键字的值
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
'------------------------------------------------------------
'读相应的键值
'------------------------------------------------------------
Select Case lKeyValType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据
类型
'--------------------------------
tmpVal = String$(1024, 0) ' 分配变量空间
KeyValSize = 1024 ' 标记变量尺寸
rc = RegQueryValueEx_SZ(hKey, SubKeyName, 0, 0, tmpVal, KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
If InStr(tmpVal, Chr(0)) > 0 Then sKeyVal = Left(tmpVal, InStr(tmpVal, Chr(0)) - 1) ' 复制字符串的值
'--------------------------------
Case REG_DWORD ' 四字节注册表关键字数
据类型
'--------------------------------
KeyValSize = 1024 ' 标记变量尺寸
rc = RegQueryValueEx_DWORD(hKey, SubKeyName, 0, 0, lngValue, KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = "0x" + Hex(lngValue)
'--------------------------------
Case REG_BINARY ' 二进制字符串
'--------------------------------
rc = RegQueryValueEx(hKey, SubKeyName, 0, 0, bytValue(0), KeyValSize)
' 获得/创建关键字的值
If rc <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = ""
For i = 1 To KeyValSize
If Len(Hex$(bytValue(i - 1))) = 1 Then
sKeyVal = sKeyVal + "0" + Hex(bytValue(i - 1)) + " "
Else
sKeyVal = sKeyVal + Hex(bytValue(i - 1)) + " "
End If
Next i
'--------------------------------
Case Else
'--------------------------------
sKeyVal = ""
'--------------------------------
End Select
'----------------------------------------
ReadRegKey = sKeyVal ' 返回值
rc = RegCloseKey(hKey) ' 关闭注册表关键字
Exit Function ' 退出
'-----------------------------------------------------------------------------------------
GetKeyError: ' 错误发生过后进行清除...
ReadRegKey = "" ' 设置返回值为错误
rc = RegCloseKey(hKey) ' 关闭注册表关键字
End Function
'*************************************************************************
'**函 数 名：DelRegKey
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(Long) - 状态码
'**功能描述：删除关键字
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function DelRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
DelRegKey = 0 ' 假定成功
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegKey = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'删除关键字
DelRegKey = RegDeleteKey(lKeyId, ByVal SubKeyName)
End If
End Function
'*************************************************************************
'**函 数 名：DelRegValue
'**输 入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输 出：(Long) - 状态码
'**功能描述：从登录关键字中删除一个值
'**全局变量：
'**调用模块：
'**作 者：叶帆
'**日 期：2003年01月11日
'**修 改 人：
'**日 期：
'**版 本：版本1.0
'*************************************************************************
Public Function DelRegValue(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
DelRegValue = 0 ' 假定成功
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegValue = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'从登录关键字中删除一个值
DelRegValue = RegDeleteValue(lKeyId, ByVal SubKeyName)
End If
End Function
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal numBytes As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" _
(ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
'//注册表 API 函数声明
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) 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 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
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpbData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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 RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName 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 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
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal ipValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpValue 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, _
lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Byte, ByVal cbData As Long) As Long
Private Declare Function RegQueryInfoKey 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 RegEnumValueInt 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 RegEnumValueStr 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 RegEnumValueByte 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 Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'//注册表访问权
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = &H3F
'//打开/建立选项
Const REG_OPTION_NON_VOLATILE = 0&
Const REG_OPTION_VOLATILE = &H1
'//Key 创建/打开
Const REG_CREATED_NEW_KEY = &H1
Const REG_OPENED_EXISTING_KEY = &H2
'//预定义存取类型
Const STANDARD_RIGHTS_ALL = &H1F0000
Const SPECIFIC_RIGHTS_ALL = &HFFFF
'//严格代码定义
Const ERROR_SUCCESS = 0&
Const ERROR_ACCESS_DENIED = 5
Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_MORE_DATA = 234 '// 错误
'//注册表值类型列举
Private Enum RegDataTypeEnum
' REG_NONE = (0) '// No value type
REG_SZ = (1) '// Unicode nul terminated string
REG_EXPAND_SZ = (2) '// Unicode nul terminated string w/enviornment var
REG_BINARY = (3) '// Free form binary
REG_DWORD = (4) '// 32-bit number
REG_DWORD_LITTLE_ENDIAN = (4) '// 32-bit number (same as REG_DWORD)
REG_DWORD_BIG_ENDIAN = (5) '// 32-bit number
' REG_LINK = (6) '// Symbolic Link (unicode)
REG_MULTI_SZ = (7) '// Multiple, null-delimited, double-null-terminated Unicode strings
' REG_RESOURCE_LIST = (8) '// Resource list in the resource map
' REG_FULL_RESOURCE_DESCRIPTOR = (9) '// Resource list in the hardware description
' REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum
'//注册表基本键值列表
Public Enum RootKeyEnum
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA_WIN2K_ONLY = &H80000004 '//仅Win2k
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
'// for specifying the type of data to save
Public Enum RegValueTypes
eInteger = vbInteger
eLong = vbLong
eString = vbString
eByteArray = vbArray + vbByte
End Enum
'//保存时指定类型
Public Enum RegFlags
IsExpandableString = 1
IsMultiString = 2
'IsBigEndian = 3 '// 无指针同样不要设置大Endian值
End Enum
Private Const ERR_NONE = 0
Function SetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, ByVal Value As Variant, valueType As RegValueTypes, _
Optional Flag As RegFlags = 0) As Boolean
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim length As Long
Dim retVal As Long
Dim SecAttr As SECURITY_ATTRIBUTES '//键的安全设置
'//设置新键值的名称和默认安全设置
SecAttr.nLength = Len(SecAttr) '//结构大小
SecAttr.lpSecurityDescriptor = 0 '//默认安全权限
SecAttr.bInheritHandle = True '//设置的默认值
'// 打开或创建键
'If RegOpenKeyEx(hKey, KeyName, 0, KEY_ALL_ACCESS, handle) Then Exit Function
retVal = RegCreateKeyEx(hKey, KeyName, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, SecAttr, handle, retVal)
If retVal Then Exit Function
'//3种数据类型
Select Case VarType(Value)
Case vbByte, vbInteger, vbLong '// 若是字节, Integer值或Long值...
lngValue = Value
retVal = RegSetValueExLong(handle, ValueName, 0, REG_DWORD, lngValue, Len(lngValue))
Case vbString '// 字符串, 扩展环境字符串或多段字符串...
strValue = Value
Select Case Flag
Case IsExpandableString
retVal = RegSetValueEx(handle, ValueName, 0, REG_EXPAND_SZ, ByVal strValue, 255)
Case IsMultiString
retVal = RegSetValueEx(handle, ValueName, 0, REG_MULTI_SZ, ByVal strValue, 255)
Case Else '// 正常 REG_SZ 字符串
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, 255)
End Select
Case vbArray + vbByte '// 如果是字节数组...
binValue = Value
length = UBound(binValue) - LBound(binValue) + 1
retVal = RegSetValueExByte(handle, ValueName, 0, REG_BINARY, binValue(0), length)
Case Else '// 如果其它类型
RegCloseKey handle
'Err.Raise 1001, , "不支持的值类型"
End Select
'// 返回关闭结果
RegCloseKey handle
'// 返回写入成功结果
SetRegistryValue = (retVal = 0)
End Function
Function GetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
Const KEY_READ = &H20019
'// 默认结果
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
'// 打开键, 不存在则退出
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
'// 准备 1K resBinary 用于接收
length = 1024
ReDim resBinary(0 To length - 1) As Byte
'// 读注册表值
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
'// 若resBinary 太小则重读
If retVal = ERROR_MORE_DATA Then
'// resBinary放大,且重新读取
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
'// 返回相应值类型
Select Case valueType
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
'// REG_DWORD 和 REG_DWORD_LITTLE_ENDIAN 相同
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_DWORD_BIG_ENDIAN
'// Big Endian's 用在非-Windows环境, 如Unix系统, 本地计算机远程访问
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = SwapEndian(resLong)
Case REG_SZ, REG_EXPAND_SZ
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
If valueType = REG_EXPAND_SZ Then
'// 查询对应的环境变量
GetRegistryValue = ExpandEnvStr(resString)
Else
GetRegistryValue = resString
End If
Case REG_MULTI_SZ
'// 复制时需指定2个空格符
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else ' 包含 REG_BINARY
'// resBinary 调整
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
End Select
'// 关闭
RegCloseKey handle
End Function
Public Function DeleteRegistryValueOrKey(ByVal hKey As RootKeyEnum, RegKeyName As String, _
ValueName As String) As Boolean
'//删除注册表值和键,如果成功返回True
Dim lRetval As Long '//打开和输出注册表键的返回值
Dim lRegHWND As Long '//打开注册表键的句柄
Dim sREGSZData As String '//把获取值放入缓冲区
Dim lSLength As Long '//缓冲区大小. 改变缓冲区大小要在调用之后
'//打开键
lRetval = RegOpenKeyEx(hKey, RegKeyName, 0, KEY_ALL_ACCESS, lRegHWND)
'//成功打开
If lRetval = ERR_NONE Then
'//删除指定值
lRetval = RegDeleteValue(lRegHWND, ValueName) '//如果已存在则先删除
'//如出现错误则删除值并返回False
If lRetval <> ERR_NONE Then Exit Function
'//注意: 如果成功打开仅关闭注册表键
lRetval = RegCloseKey(lRegHWND)
'//如成功关闭则返回 True 或者其它错误
If lRetval = ERR_NONE Then DeleteRegistryValueOrKey = True
End If
End Function
Private Function ExpandEnvStr(sData As String) As String
'// 查询环境变量和返回定义值
'// 如： %PATH% 则返回 "c:\;c:\windows;"
Dim c As Long, s As String
s = "" '// 不支持Windows 95
'// get the length
c = ExpandEnvironmentStrings(sData, s, c)
'// 展开字符串
s = String$(c - 1, 0)
c = ExpandEnvironmentStrings(sData, s, c)
'// 返回环境变量
ExpandEnvStr = s
End Function
Private Function SwapEndian(ByVal dw As Long) As Long
'// 转换大DWord 到小 DWord
CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal numBytes As Long)
Private Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" _
(ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
'//注册表 API 函数声明
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) 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 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
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpbData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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 RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" _
(ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
ByVal cbName 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 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
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal ipValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
ByVal lpValue 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, _
lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExByte Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, _
ByVal Reserved As Long, ByVal dwType As Long, _
lpValue As Byte, ByVal cbData As Long) As Long
Private Declare Function RegQueryInfoKey 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 RegEnumValueInt 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 RegEnumValueStr 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 RegEnumValueByte 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 Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'//注册表访问权
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_ALL_ACCESS = &H3F
'//打开/建立选项
Const REG_OPTION_NON_VOLATILE = 0&
Const REG_OPTION_VOLATILE = &H1
'//Key 创建/打开
Const REG_CREATED_NEW_KEY = &H1
Const REG_OPENED_EXISTING_KEY = &H2
'//预定义存取类型
Const STANDARD_RIGHTS_ALL = &H1F0000
Const SPECIFIC_RIGHTS_ALL = &HFFFF
'//严格代码定义
Const ERROR_SUCCESS = 0&
Const ERROR_ACCESS_DENIED = 5
Const ERROR_NO_MORE_ITEMS = 259
Const ERROR_MORE_DATA = 234 '// 错误
'//注册表值类型列举
Private Enum RegDataTypeEnum
' REG_NONE = (0) '// No value type
REG_SZ = (1) '// Unicode nul terminated string
REG_EXPAND_SZ = (2) '// Unicode nul terminated string w/enviornment var
REG_BINARY = (3) '// Free form binary
REG_DWORD = (4) '// 32-bit number
REG_DWORD_LITTLE_ENDIAN = (4) '// 32-bit number (same as REG_DWORD)
REG_DWORD_BIG_ENDIAN = (5) '// 32-bit number
' REG_LINK = (6) '// Symbolic Link (unicode)
REG_MULTI_SZ = (7) '// Multiple, null-delimited, double-null-terminated Unicode strings
' REG_RESOURCE_LIST = (8) '// Resource list in the resource map
' REG_FULL_RESOURCE_DESCRIPTOR = (9) '// Resource list in the hardware description
' REG_RESOURCE_REQUIREMENTS_LIST = (10)
End Enum
'//注册表基本键值列表
Public Enum RootKeyEnum
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA_WIN2K_ONLY = &H80000004 '//仅Win2k
HKEY_CURRENT_CONFIG = &H80000005
HKEY_DYN_DATA = &H80000006
End Enum
'// for specifying the type of data to save
Public Enum RegValueTypes
eInteger = vbInteger
eLong = vbLong
eString = vbString
eByteArray = vbArray + vbByte
End Enum
'//保存时指定类型
Public Enum RegFlags
IsExpandableString = 1
IsMultiString = 2
'IsBigEndian = 3 '// 无指针同样不要设置大Endian值
End Enum
Private Const ERR_NONE = 0
Function SetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, ByVal Value As Variant, valueType As RegValueTypes, _
Optional Flag As RegFlags = 0) As Boolean
Dim handle As Long
Dim lngValue As Long
Dim strValue As String
Dim binValue() As Byte
Dim length As Long
Dim retVal As Long
Dim SecAttr As SECURITY_ATTRIBUTES '//键的安全设置
'//设置新键值的名称和默认安全设置
SecAttr.nLength = Len(SecAttr) '//结构大小
SecAttr.lpSecurityDescriptor = 0 '//默认安全权限
SecAttr.bInheritHandle = True '//设置的默认值
'// 打开或创建键
'If RegOpenKeyEx(hKey, KeyName, 0, KEY_ALL_ACCESS, handle) Then Exit Function
retVal = RegCreateKeyEx(hKey, KeyName, 0, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, SecAttr, handle, retVal)
If retVal Then Exit Function
'//3种数据类型
Select Case VarType(Value)
Case vbByte, vbInteger, vbLong '// 若是字节, Integer值或Long值...
lngValue = Value
retVal = RegSetValueExLong(handle, ValueName, 0, REG_DWORD, lngValue, Len(lngValue))
Case vbString '// 字符串, 扩展环境字符串或多段字符串...
strValue = Value
Select Case Flag
Case IsExpandableString
retVal = RegSetValueEx(handle, ValueName, 0, REG_EXPAND_SZ, ByVal strValue, 255)
Case IsMultiString
retVal = RegSetValueEx(handle, ValueName, 0, REG_MULTI_SZ, ByVal strValue, 255)
Case Else '// 正常 REG_SZ 字符串
retVal = RegSetValueEx(handle, ValueName, 0, REG_SZ, ByVal strValue, 255)
End Select
Case vbArray + vbByte '// 如果是字节数组...
binValue = Value
length = UBound(binValue) - LBound(binValue) + 1
retVal = RegSetValueExByte(handle, ValueName, 0, REG_BINARY, binValue(0), length)
Case Else '// 如果其它类型
RegCloseKey handle
'Err.Raise 1001, , "不支持的值类型"
End Select
'// 返回关闭结果
RegCloseKey handle
'// 返回写入成功结果
SetRegistryValue = (retVal = 0)
End Function
Function GetRegistryValue(ByVal hKey As RootKeyEnum, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
Const KEY_READ = &H20019
'// 默认结果
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
'// 打开键, 不存在则退出
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
'// 准备 1K resBinary 用于接收
length = 1024
ReDim resBinary(0 To length - 1) As Byte
'// 读注册表值
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), length)
'// 若resBinary 太小则重读
If retVal = ERROR_MORE_DATA Then
'// resBinary放大,且重新读取
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
'// 返回相应值类型
Select Case valueType
Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
'// REG_DWORD 和 REG_DWORD_LITTLE_ENDIAN 相同
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_DWORD_BIG_ENDIAN
'// Big Endian's 用在非-Windows环境, 如Unix系统, 本地计算机远程访问
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = SwapEndian(resLong)
Case REG_SZ, REG_EXPAND_SZ
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
If valueType = REG_EXPAND_SZ Then
'// 查询对应的环境变量
GetRegistryValue = ExpandEnvStr(resString)
Else
GetRegistryValue = resString
End If
Case REG_MULTI_SZ
'// 复制时需指定2个空格符
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else ' 包含 REG_BINARY
'// resBinary 调整
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
End Select
'// 关闭
RegCloseKey handle
End Function
Public Function DeleteRegistryValueOrKey(ByVal hKey As RootKeyEnum, RegKeyName As String, _
ValueName As String) As Boolean
'//删除注册表值和键,如果成功返回True
Dim lRetval As Long '//打开和输出注册表键的返回值
Dim lRegHWND As Long '//打开注册表键的句柄
Dim sREGSZData As String '//把获取值放入缓冲区
Dim lSLength As Long '//缓冲区大小. 改变缓冲区大小要在调用之后
'//打开键
lRetval = RegOpenKeyEx(hKey, RegKeyName, 0, KEY_ALL_ACCESS, lRegHWND)
'//成功打开
If lRetval = ERR_NONE Then
'//删除指定值
lRetval = RegDeleteValue(lRegHWND, ValueName) '//如果已存在则先删除
'//如出现错误则删除值并返回False
If lRetval <> ERR_NONE Then Exit Function
'//注意: 如果成功打开仅关闭注册表键
lRetval = RegCloseKey(lRegHWND)
'//如成功关闭则返回 True 或者其它错误
If lRetval = ERR_NONE Then DeleteRegistryValueOrKey = True
End If
End Function
Private Function ExpandEnvStr(sData As String) As String
'// 查询环境变量和返回定义值
'// 如： %PATH% 则返回 "c:\;c:\windows;"
Dim c As Long, s As String
s = "" '// 不支持Windows 95
'// get the length
c = ExpandEnvironmentStrings(sData, s, c)
'// 展开字符串
s = String$(c - 1, 0)
c = ExpandEnvironmentStrings(sData, s, c)
'// 返回环境变量
ExpandEnvStr = s
End Function
Private Function SwapEndian(ByVal dw As Long) As Long
'// 转换大DWord 到小 DWord
CopyMemory ByVal VarPtr(SwapEndian) + 3, dw, 1
CopyMemory ByVal VarPtr(SwapEndian) + 2, ByVal VarPtr(dw) + 1, 1
CopyMemory ByVal VarPtr(SwapEndian) + 1, ByVal VarPtr(dw) + 2, 1
CopyMemory SwapEndian, ByVal VarPtr(dw) + 3, 1
End Function
| 发表评论 - 不要忘了输入验证码哦！ |