在VB中读写注册表函数源码

在以下地址贴中有乱码,

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 aclearcase/" target="_blank" >ccurr, 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