在以下地址贴中有乱码,
http://www.csdn.net/develop/article/8/8562.shtm
现补充如下:
Public Function SysRegControl(Optional ByVal RootKey As RegRootKey = regHKEY_LOCAL_MACHINE, Optional ByVal SubKey As String = "", Optional ByVal Key As String = "QiLin", Optional ByRef KeyValue As Variant = "", Optional regKeyType As regKeyTypes = regTypeString, Optional ByVal id As RegControlID = regSetKeyValue) As Boolean
'***************************************************************************************
'setregkey 函数
'功能：
' 对注册表中指定键键进行操作
'参数:
' RootKey 根键
'RootKey 说明
'{ regHKEY_CLASSES_ROOT = &H80000000
' regHKEY_CURRENT_USER = &H80000001
' regHKEY_LOCAL_MACHINE = &H80000002
' regHKEY_USERS = &H80000003
' regHKEY_PERFORMANCE_DATA = &H80000004
' regHKEY_CURRENT_CONFIG = &H80000005
' regHKEY_DYN_DATA = &H80000006
'}
' SubKey 子键路径
' Key 设置的键名
' KeyValue 设置的键值
' regKeyType 指定键值的类型
'regKeyType说明:
'{
' regTypeBinary =&H00000001 'Binary
' regTypeDword =&H00000002 'DWORD
' regTypeString =&H00000003 'String
'}
' ID 函数操作功能号
'功能ID说明:
'{ regSetKeyValue =111 '设置键值
' regGetKeyValue =112 '取键值
' regCreatKey =113 '创建子键
' regDeleteKeys =114 '删除末级子键
' regDelAllKey =115 '删除非末级子键
' regDeleteValues =116 '删除键值
' regOther =120 '保留操作ID
'}
'返回值:
' TRUE 操作成功
' FALSE 操作失败
' (C)2001.3.2
'*****************************************************************************************
Dim i As Long
On Error GoTo RegOptionError
'if RootKey then
Select Case id
'=========================================================================================
Case regSetKeyValue '=111 '设置键值
'=========================================================================================
rtn = RegOpenKeyEx(RootKey, SubKey, 0, KEY_WRITE, hKey)
If rtn = ERROR_SUCCESS Then
'{
Select Case regKeyType
'----------------------------------------------------------------------------------------
Case regTypeBinary '=&H00000001 'Binary
'此模式下参数KeyValue须以字符串形式传入,调用实例:
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", "jadgekylin@yesky.com", regTypeBinary, regSetKeyValue
'----------------------------------------------------------------------------------------
If VarType(KeyValue) <> vbString Then '参数不合法
rtn = ERROR_SUCCESS + 1
'exit select
Else
lDataSize = Len(KeyValue)
ReDim ByteArray(lDataSize)
For i = 1 To lDataSize
ByteArray(i) = Asc(Mid$(KeyValue, i, 1))
Next
rtn = RegSetValueExB(hKey, Key, 0, REG_BINARY, ByteArray(1), lDataSize) 'write the value
End If
'----------------------------------------------------------------------------------------
Case regTypeDword '=&H00000002 'DWORD
'调用实例:
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", 1, regTypeDword, regSetKeyValue
'----------------------------------------------------------------------------------------
If VarType(KeyValue) <> vbLong And VarType(KeyValue) <> vbInteger Then
rtn = ERROR_SUCCESS + 1
'exit select
Else
rtn = RegSetValueExA(hKey, Key, 0, REG_DWORD, KeyValue, 4) 'write the value
End If
'----------------------------------------------------------------------------------------
Case regTypeString '=&H00000003 'String
'调用实例:
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", "1", regTypeString, regSetKeyValue
'----------------------------------------------------------------------------------------
If VarType(KeyValue) <> vbString Then '参数不合法
rtn = ERROR_SUCCESS + 1
'exit select
Else
rtn = RegSetValueEx(hKey, Key, 0, REG_SZ, ByVal KeyValue, Len(KeyValue)) 'write the value
End If
'----------------------------------------------------------------------------------------
End Select
'}
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
rtn = RegCloseKey(hKey)
SysRegControl = False '调用失败
Exit Function
End If
rtn = RegCloseKey(hKey) 'close the key
End If 'rtn = ERROR_SUCCESS
'=========================================================================================
Case regGetKeyValue '=112 '取键值
'=========================================================================================
rtn = RegOpenKeyEx(RootKey, SubKey, 0, KEY_READ, hKey)
If rtn = ERROR_SUCCESS Then 'if the key could be opened
'{
Select Case regKeyType
'----------------------------------------------------------------------------------------
Case regTypeBinary '=&H00000001 'Binary
'KeyValue作为传值变量获得键值,调用示例:
'Dim a As String
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", a, regTypeBinary, regGetKeyValue
'----------------------------------------------------------------------------------------
rtn = RegQueryValueEx(hKey, Key, 0, REG_BINARY, 0, lBufferSize) 'get the value from the registry
sBuffer = Space(lBufferSize)
rtn = RegQueryValueEx(hKey, Key, 0, REG_BINARY, sBuffer, lBufferSize) 'get the value from the registry
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
rtn = RegCloseKey(hKey)
SysRegControl = False '调用失败
Exit Function
Else
KeyValue = sBuffer
End If
rtn = RegCloseKey(hKey) 'close the key
'----------------------------------------------------------------------------------------
Case regTypeDword '=&H00000002 'DWORD
'
'KeyValue作为传值变量获得键值,调用示例:
'Dim a As Long
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", a, regTypeString, regGetKeyValue
'----------------------------------------------------------------------------------------
rtn = RegQueryValueExA(hKey, Key, 0, REG_DWORD, lBuffer, 4) 'get the value from the registry
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
rtn = RegCloseKey(hKey)
SysRegControl = False '调用失败
Exit Function
Else
KeyValue = lBuffer
End If
rtn = RegCloseKey(hKey) 'close the key
'----------------------------------------------------------------------------------------
Case regTypeString '=&H00000003 'String
'KeyValue作为传值变量获得键值,调用示例:
'Dim a As String
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos1", a, regTypeString, regGetKeyValue
'----------------------------------------------------------------------------------------
sBuffer = Space(255) 'make a buffer
lBufferSize = Len(sBuffer)
rtn = RegQueryValueEx(hKey, Key, 0, REG_SZ, sBuffer, lBufferSize) 'get the value from the registry
sBuffer = Trim(sBuffer)
sBuffer = Left(sBuffer, Len(sBuffer) - 1) 'return the value to the user
If Not rtn = ERROR_SUCCESS Then 'if the was an error writting the value
rtn = RegCloseKey(hKey)
SysRegControl = False '调用失败
Exit Function
Else
KeyValue = sBuffer
End If
rtn = RegCloseKey(hKey) 'close the key
'----------------------------------------------------------------------------------------
End Select
'}
End If 'rtn = ERROR_SUCCESS
'=========================================================================================
Case regCreatKey '=113 '创建子键
'SubKey 是创建对象,Key,KeyValue为保留字,调用示例:
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos\pos", "", 0, regTypeDword, regCreatKey
'=========================================================================================
rtn = RegCreateKey(RootKey, SubKey, hKey) 'create the key
If Not rtn = ERROR_SUCCESS Then 'if the key was created then
rtn = RegCloseKey(hKey) 'close the key
SysRegControl = False
Exit Function
End If
'=========================================================================================
Case regDeleteKeys '=114 '删除末级子键同regDelAllKey
'此处Key指定为SubKey下一级子键即被删除子键,SubKey可以为"",key若为"",则删除SubKey子键
'调用示例:
'SysRegControl regHKEY_LOCAL_MACHINE, "", "jadgekylin", "", regTypeBinary, regDeleteKeys
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin", "", "", regTypeBinary, regDeleteKeys
'SysRegControl regHKEY_LOCAL_MACHINE, "" , "jadgekylin", "", regTypeBinary, regDeleteKeys
'=========================================================================================
rtn = RegOpenKeyEx(RootKey, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegDeleteKey(hKey, Key) 'delete the key
Else
rtn = RegCloseKey(hKey) 'close the key
SysRegControl = False
Exit Function
End If
'=========================================================================================
Case regDelAllKey '=115 '删除非末级子键,暂时同RegDeleteKeys
'=========================================================================================
rtn = RegOpenKeyEx(RootKey, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then 'if the key could be opened then
rtn = RegDeleteKey(hKey, Key) 'delete the key
Else
rtn = RegCloseKey(hKey) 'close the key
SysRegControl = False
Exit Function
End If
'=========================================================================================
Case regDeleteValues '=116 '删除键值
'
'此处KeyValue,regKeyType为保留字,可以设为任意值,调用示例:
'SysRegControl regHKEY_LOCAL_MACHINE, "jadgekylin\jklpos", "pos", 0, regTypeDword, regDeleteValues
'=========================================================================================
rtn = RegOpenKeyEx(RootKey, SubKey, 0, KEY_WRITE, hKey) 'open the key
If rtn = ERROR_SUCCESS Then
rtn = RegDeleteValue(hKey, Key)
Else
rtn = RegCloseKey(hKey)
SysRegControl = False
Exit Function
End If
'=========================================================================================
Case regOther '=120 '保留操作ID
'=========================================================================================
'=========================================================================================
Case Else
'=========================================================================================
SysRegControl = False
Exit Function
End Select
'end if 'RootKey
On Error GoTo 0
SysRegControl = True
Exit Function
RegOptionError: '错误处理过程
'If an error does accurr, and the user wants error messages displayed, then
'display one of the following error messages
Dim lErrorCode As Long
Dim GetErrorMsg As String
lErrorCode = Err()
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 = Chr(13) & Chr(10) & Error(Err())
End Select
MsgBox "Error: " & Err() & GetErrorMsg
Exit Function
Resume
End Function
