VB6 注册表的递归访问与面象对象模块化封装

总述

1）较低层次的封装 “过程化模块封装” 模块： Module1包含windows API 注册表相关函数声明 及少量的 GetValue、SetValue函数等浅封装。
2）较高层次的封装 基于面向对象：类模块CEnumReg定义属性、方法、事件。

CEnumReg 接口说明

核心方法

EnumAll(hkey As Long, ByVal subkey As String)

1.该方法的作用递归枚举指定 “注册表项句柄”（或指定句柄的子项）的全部注册表项；
2. 该方法是 递归方法 ，会多次触发 EnumLeaf、 EnumNode、EnumFinished 等事件；（这里把没有子项的“键值对“称为Leaf，把有子项的称为Node）当然如果枚举失败会触发对应的错误事件：EnumError事件，当枚举完成会触发EnumFinished事件。

DeleteTreeKey(ByVal hkey As Long, ByVal subkey As String)

1.该方法的作用删除指定 “注册表项句柄”（或指定句柄的子项）的全部注册表项；
2. 该方法也是 递归方法 ，会多次触发 DeletedNode 事件；当然如果某个结点删除失败会触发对应的错误事件：DeleteError事件。

CancelEnum()

1.该方法的作用放弃枚举EnumAll方法。
2. 该方法调用后 EnumAll 并不是立即返回，CancelEnum方法只是使放弃标记可用，当递归EnumAll方法执行遇到放弃标记代码段仅放弃该层方法返回上一层调用，当上层方法也执行到放弃标记处也放弃当前层方法，直到全部递归调用全部返回。

属性

RunningNum
1.该只读属性的作用返回当前正在运行递归函数的深度。（也可理解为当前进入注册表项的层数）

事件

EnumLeaf(ByVal hkey As Long, ByRef parentNodes() As String, ByVal parentNodeLevel As Long, ByVal subkey As String, ByVal keyName As String, keyValue As Variant, keyValueType As Long)
当EnumAll递归枚举到没有子项的注册项时(即键值对)该事件触发。
1.参数hkey注册表项句柄
2.参数parentNodes()存放当前项的每级父结点项的名称（键名）。
3.参数parentNodeLevel当前结点所在层级。
4.参数subkey子项名（子键名）
5.参数keyName 键值对的键名
6.参数keyValue 键值对的键值

EnumNode、DeletedNode、EnumFinished、DeleteError、EnumError 事件参数基本类似或根据参数名可以推测出其含义，或跟据源码推测出其用法，这里就不在赘述。

module1

Option Explicit

'注册表主键
Public Enum enumRegMainKey
   iHKEY_CLASSES_ROOT = &H80000000
   iHKEY_CURRENT_USER = &H80000001
   iHKEY_LOCAL_MACHINE = &H80000002
   iHKEY_USERS = &H80000003
   iHKEY_CURRENT_CONFIG = &H80000005
End Enum

'注册表数据类型
Public Enum enumRegSzType
   iREG_SZ = &H1 '符串值 (REG_SZ) 最长255
   iREG_EXPAND_SZ = &H2 '可扩充符串值
   iREG_BINARY = &H3 '二进制值 (REG_BINARY)
   iREG_DWORD = &H4 'DWORD值（REG_DWORD）由 4 字节长（32 位整数）的数字表示的数据。
   iREG_NONE = 0& '空
   iREG_DWORD_LITTLE_ENDIAN = 4&
   iREG_DWORD_BIG_ENDIAN = 5&
   iREG_LINK = 6&
   iREG_MULTI_SZ = 7& '多字符串值 (REG_SZ) 最长255
   iREG_RESOURCE_LIST = 8&
   iREG_FULL_RESOURCE_DEscription = 9&
   iREG_RESOURCE_REQUIREMENTS_LIST = 10&
End Enum
'注册表
Public Const ERROR_SUCCESS = 0&
Public Const ERROR_BADDB = 1009&
Public Const ERROR_BADKEY = 1010&
Public Const ERROR_CANTOPEN = 1011&
Public Const ERROR_CANTREAD = 1012&
Public Const ERROR_CANTWRITE = 1013&
Public Const ERROR_OUTOFMEMORY = 14&
Public Const ERROR_INVALID_PARAMETER = 87&
Public Const ERROR_ACCESS_DENIED = 5&
Public Const ERROR_NO_MORE_ITEMS = 259&
Public Const ERROR_MORE_DATA = 234&
Public Const KEY_QUERY_VALUE = &H1&
Public Const KEY_SET_VALUE = &H2&
Public Const KEY_CREATE_SUB_KEY = &H4&
Public Const KEY_ENUMERATE_SUB_KEYS = &H8&
Public Const KEY_NOTIFY = &H10&
Public Const KEY_CREATE_LINK = &H20&
Public Const SYNCHRONIZE = &H100000
Public Const READ_CONTROL = &H20000
Public Const WRITE_DAC = &H40000
Public Const WRITE_OWNER = &H80000
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const STANDARD_RIGHTS_READ = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE = READ_CONTROL
Public Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Public Const KEY_WRITE = STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Public Const KEY_EXECUTE = KEY_READ
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Public 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
Public 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
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpValueName As String) As Long


Public 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
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Long, ByVal cbData As Long) As Long

Public 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
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

Public 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

Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long

Public Declare Function RegSaveKey Lib "advapi32.dll" Alias "RegSaveKeyA" (ByVal hkey As Long, ByVal lpFile As String, ByVal lpSecurityAttributes As Long) As Long
Public Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" (ByVal hkey As Long, ByVal lpFile As String, ByVal dwflags As Long) As Long


Public Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type
Public Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescription As Long
   bInheritHandle As Boolean
End Type

'键值对
Public Type CKVP
    keyName As String
    keyValue As Long
End Type



Public Function GetValue(ByVal mainKey As enumRegMainKey, _
                        ByVal subkey As String, _
                        ByVal keyV As String, _
                        ByRef sValue As Variant, _
                        Optional ByRef rlngErrNum As Long, _
                        Optional ByRef rstrErrDescr As String) As Boolean
   Dim hkey As Long, lType As Long, lBuffer As Long, sBuffer As String, ldata As Long
   On Error GoTo GetValueErr
   GetValue = False
   If RegOpenKeyEx(mainKey, subkey, 0, KEY_READ, hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "获取注册表值时出错"
   End If
   If RegQueryValueEx(hkey, keyV, 0, lType, ByVal 0, lBuffer) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "获取注册表值时出错"
   End If
   Select Case lType
      Case iREG_SZ
         lBuffer = 255
         sBuffer = Space(lBuffer)
         If RegQueryValueEx(hkey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
         End If
         sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
      Case iREG_EXPAND_SZ
         sBuffer = Space(lBuffer)
         If RegQueryValueEx(hkey, keyV, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
         End If
         sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
      Case iREG_DWORD
         If RegQueryValueEx(hkey, keyV, 0, lType, ldata, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
         End If
         sValue = ldata
      Case iREG_BINARY
         If RegQueryValueEx(hkey, keyV, 0, lType, ldata, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "获取注册表值时出错"
         End If
         sValue = ldata
   End Select
   If RegCloseKey(hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "获取注册表值时出错"
   End If
   GetValue = True
   Err.Clear
GetValueErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function
Public Function SetValue(ByVal mainKey As enumRegMainKey, _
                        ByVal subkey As String, _
                        ByVal keyV As String, _
                        ByVal lType As enumRegSzType, _
                        ByVal sValue As Variant, _
                        Optional ByRef rlngErrNum As Long, _
                        Optional ByRef rstrErrDescr As String) As Boolean
   Dim s As Long, lBuffer As Long, hkey As Long
   Dim ss As SECURITY_ATTRIBUTES
   On Error GoTo SetValueErr
   SetValue = False
   ss.nLength = Len(ss)
   ss.lpSecurityDescription = 0
   ss.bInheritHandle = True
   If RegCreateKeyEx(mainKey, "", 0, "", 0, KEY_WRITE, ss, hkey, s) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "设置注册表时出错"
   End If
   Select Case lType
      Case iREG_SZ
         lBuffer = LenB(sValue)
         If RegSetValueEx(hkey, subkey, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
         End If
      Case iREG_EXPAND_SZ
         lBuffer = LenB(sValue)
         If RegSetValueEx(hkey, subkey, 0, lType, ByVal sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
         End If
      Case iREG_DWORD
         lBuffer = 4
         If RegSetValueExA(hkey, subkey, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
         End If
      Case iREG_BINARY
         lBuffer = 4
         If RegSetValueExA(hkey, subkey, 0, lType, sValue, lBuffer) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "设置注册表时出错"
         End If
      Case Else
         Err.Raise vbObjectError + 1, , "不支持该参数类型"
   End Select
   If RegCloseKey(hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "设置注册表时出错"
   End If
   SetValue = True
   Err.Clear
SetValueErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function
Public Function DeleteValue(ByVal mainKey As enumRegMainKey, _
                           ByVal subkey As String, _
                           ByVal keyName As String, _
                           Optional ByRef rlngErrNum As Long, _
                           Optional ByRef rstrErrDescr As String) As Boolean
   Dim hkey As Long
   On Error GoTo DeleteValueErr
   DeleteValue = False
   If RegOpenKeyEx(mainKey, subkey, 0, KEY_WRITE, hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   If RegDeleteValue(hkey, keyName) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   If RegCloseKey(hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   DeleteValue = True
   Err.Clear
DeleteValueErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function
Public Function DeleteKey(ByVal mainKey As enumRegMainKey, _
                           ByVal subkey As String, _
                           Optional ByRef rlngErrNum As Long, _
                           Optional ByRef rstrErrDescr As String) As Boolean
   Dim hkey As Long
   On Error GoTo DeleteKeyErr
   DeleteKey = False
   'RegOpenKeyEx(hkey, subkey, 0, KEY_READ, hSubKey)
   If RegOpenKeyEx(mainKey, subkey, 0, KEY_WRITE, hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   If RegDeleteKey(hkey, subkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   If RegCloseKey(hkey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "删除注册表值时出错"
   End If
   DeleteKey = True
   Err.Clear
DeleteKeyErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
End Function

类模块CRegEnum.cls

Option Explicit
Dim mCancelEnum As Boolean


Dim rlngErrNum As Long, rstrErrDescr As String

Dim parentNodes(16) As String

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent EnumLeaf[(arg1, arg2, ... , argn)]
Public Event EnumLeaf(ByVal hkey As Long, ByRef parentNodes() As String, ByVal parentNodeLevel As Long, ByVal subkey As String, ByVal keyName As String, keyValue As Variant, keyValueType As Long)

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent EnumNode[(arg1, arg2, ... , argn)]
Public Event EnumNode(ByVal hkey As Long, ByRef parentNodes() As String, ByVal parentNodeLevel As Long, ByVal subkey As String)


'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent DeletedNode[(arg1, arg2, ... , argn)]
Public Event DeletedNode(ByVal hkey As Long, ByVal subkey As String)


'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent EnumFinished[(arg1, arg2, ... , argn)]
Public Event EnumFinished()

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent DeleteError[(arg1, arg2, ... , argn)]
Public Event DeleteError(ByVal hkey As Long, ByVal subkey As String, ByVal errNum As Long, ByVal errDescr As String)

'要引发该事件，请遵循下列语法使用 RaiseEvent:
'RaiseEvent DeleteError[(arg1, arg2, ... , argn)]
Public Event EnumError(ByRef parentNodes() As String, ByVal parentNodeLevel As Long, ByVal errNum As Long, ByVal errDescr As String)


'保持属性值的局部变量
Private mvarHKEY_CURRENT_USER As String '局部复制
Private mvarHKEY_LOCAL_MACHINE As String '局部复制
Private mvarHKEY_CLASSES_ROOT As String '局部复制
Private mvarHKEY_CURRENT_CONFIG As String '局部复制
Private mvarHKEY_USERS As String '局部复制
'保持属性值的局部变量
Private mvarRunningNum As Integer '局部复制


Public Property Get RunningNum() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.RunningNum
    RunningNum = mvarRunningNum
End Property

'Const HKEY_CURRENT_USER = "HKEY_CURRENT_USER"
'Const HKEY_LOCAL_MACHINE = "HKEY_LOCAL_MACHINE"
'Const HKEY_CLASSES_ROOT = "HKEY_CLASSES_ROOT"
'Const HKEY_CURRENT_CONFIG = "HKEY_CURRENT_CONFIG"
'Const HKEY_USERS = "HKEY_USERS"
'======================================================
'如果根返对应根名称不是则返回其值
'======================================================
Public Function GetRegKeyName(ByVal keyValue As Long) As String
    'On Error GoTo GetValueErr
    Select Case keyValue
    Case &H80000001
        GetRegKeyName = "HKEY_CURRENT_USER"
    Case &H80000002
    GetRegKeyName = "HKEY_LOCAL_MACHINE"
    Case &H80000000
    GetRegKeyName = "HKEY_CLASSES_ROOT"
    Case &H80000005
    GetRegKeyName = "HKEY_CURRENT_CONFIG"
    Case &H80000003
    GetRegKeyName = "HKEY_USERS"
    Case Else
        GetRegKeyName = CStr(keyValue)
     'Err.Raise vbObjectError + 1, , "不存在注册表根键名"
     
   End Select
   
'   Err.Clear
'GetValueErr:
'   rlngErrNum = Err.Number
'   rstrErrDescr = Err.Description
   'Debug.Print rstrErrDescr

End Function

'作用：枚举注册表项（及子项）
'此函数为递归函数
'会多次引发 EnumLeaf、 EnumNode、EnumFinished 等事件
Public Function EnumAll(hkey As Long, ByVal subkey As String)
   Dim dwIndex As Long, lType As Long, lBuffer As Long, sBuffer As String
   Dim sLeafKeyName       As String, lenLeafKeyName       As Long
   Dim sNodeKeyName       As String, lenNodeKeyName       As Long
   Dim LWT As FILETIME
   Dim hSubKey As Long '被打开子键句柄
   mvarRunningNum = mvarRunningNum + 1
   'MsgBox mvarRunningNum
   Debug.Print "=======>mvarRunningNum"; mvarRunningNum
   If Len(subkey) > 0 And mvarRunningNum = 1 Then
   parentNodes(mvarRunningNum - 1) = GetRegKeyName(hkey) + "\" + subkey
   ElseIf Len(subkey) > 0 Then
   parentNodes(mvarRunningNum - 1) = subkey
   Else
   parentNodes(mvarRunningNum - 1) = GetRegKeyName(hkey)
   End If
   
   If mCancelEnum Then
        Debug.Print "1取消枚举"
        'mvarRunningNum = mvarRunningNum - 1
        GoTo GetValueErr
    
   End If
   Const BUFFERLENTH = 1024
   On Error GoTo GetValueErr

   
   If RegOpenKeyEx(hkey, subkey, 0, KEY_READ, hSubKey) <> ERROR_SUCCESS Then
      'Debug.Print "打开注册表时出错"
      Err.Raise vbObjectError + 1, , "打开注册表时出错"
   End If
   Debug.Print "打开:", "父:"; hkey; "subkey:"; subkey, "子:"; hSubKey
   
   '确认是根
'    If Len(keyPath) <= 0 Then
'     keyPath = GetRegKeyName(hkey)
'   End If

    
   
   
   'Debug.Print keyPath + "\" + subkey + " 子键值:", hSubKey
   Dim NameMaxLenth As Long
   Dim leafCount As Long '叶子个数
   Dim nodeCount As Long '结点
    Dim bData() As Byte
    '定义变量lenbData表示键值的数据的字节数
    Dim lenbData As Long
    ReDim bData(BUFFERLENTH) As Byte
    lenbData = BUFFERLENTH
   Dim sClass As String, lClass As Long
   Dim lValueMaxBytes As Long '结点值的最大字节数
   
   
   lClass = BUFFERLENTH
   sClass = String(lClass, Chr(0))

   Dim outMaxSubKeyLen As Long
   Dim outlSubKey As Long
   
   outlSubKey = BUFFERLENTH
   outMaxSubKeyLen = BUFFERLENTH
   If RegQueryInfoKey(hSubKey, sClass, lClass, 0, nodeCount, outlSubKey, outMaxSubKeyLen, leafCount, NameMaxLenth, lValueMaxBytes, 0, LWT) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "查询注册表信息时出错"
   End If
        'Debug.Print keyPath, "数据类型：", lClass
    dwIndex = 0
    
    For dwIndex = dwIndex + 1 To leafCount
       If mCancelEnum Then
        Debug.Print "2取消枚举";
        GoTo GetValueErr
       End If
        'Debug.Print "in:", dwIndex, leafCount
        sLeafKeyName = String(BUFFERLENTH, Chr(0))
        lenLeafKeyName = Len(sLeafKeyName)
        '方法1
        'leafCount - dwIndex 倒序枚举为了 在枚举事件中删除枚举项引起枚举下标变化导致接下的枚举失败
        If RegEnumValue(hSubKey, leafCount - dwIndex, sLeafKeyName, lenLeafKeyName, 0, lType, bData(0), lenbData) <> ERROR_SUCCESS Then
           Err.Raise vbObjectError + 1, , "枚举注册表值时出错"
        End If
        'Debug.Print "Type:", lType
        Dim sLeafValue As String
        sLeafValue = convertdata(hSubKey, sLeafKeyName, lType)
        RaiseEvent EnumLeaf(hSubKey, parentNodes(), mvarRunningNum - 1, subkey, Left(sLeafKeyName, lenLeafKeyName), sLeafValue, lType)
        lenLeafKeyName = BUFFERLENTH
        lenbData = BUFFERLENTH
    Next
    'Debug.Print "out:", dwIndex, leafCount
    
    dwIndex = 0
    For dwIndex = dwIndex + 1 To nodeCount
       If mCancelEnum Then
        Debug.Print "3取消枚举";
        GoTo GetValueErr
       End If
        'Debug.Print "in:", dwIndex, nodeCount
        'RegEnumKeyEx(lhSubKey, i, sKeyName, lenKeyName, 0, vbNullString, 0, tFT)
        sNodeKeyName = String(BUFFERLENTH, Chr(0))
        lenNodeKeyName = Len(sNodeKeyName)
        sClass = String(BUFFERLENTH, Chr(0))
        lClass = Len(sClass)
        If RegEnumKeyEx(hSubKey, nodeCount - dwIndex, sNodeKeyName, lenNodeKeyName, 0, sClass, lClass, LWT) <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "枚举注册表键时出错"
        End If
        
                
        DoEvents
        
        '在枚举前激发事件 如果进行删除操作 后面就没法枚举了
        Call EnumAll(hSubKey, Left(sNodeKeyName, lenNodeKeyName))
        
        '需要选择一合理的地方
        RaiseEvent EnumNode(hSubKey, parentNodes(), mvarRunningNum - 1, Left(sNodeKeyName, lenNodeKeyName))
        'lenKeyName会被修改
        lenNodeKeyName = BUFFERLENTH
    Next
    'Debug.Print "out:", dwIndex, nodeCount

'    Dim n As Long, i As Long
'    n = RegEnumKeyEx(hSubKey, i, sKeyName, lenKeyName, 0, vbNullString, 0, LWT)
'    '当n非0时，表示遍历结束
'    Do Until n <> 0
'        RaiseEvent EnumNode(GetRegMainKeyName(hSubKey), subkey, Left(sKeyName, lenKeyName), bData(0))
'        '提取实际的键名
'        Debug.Print Left(sKeyName, lenKeyName)
'        '重置缓冲区的大小
'        lenKeyName = 1024
'        i = i + 1
'        n = RegEnumKeyEx(hSubKey, i, sKeyName, lenKeyName, 0, vbNullString, 0, LWT)
'    Loop
    
   If RegCloseKey(hSubKey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "关闭注册表时出错"
   End If
   
   Debug.Print "关闭:", hSubKey
   Err.Clear
GetValueErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
   mvarRunningNum = mvarRunningNum - 1
   If mvarRunningNum <= 0 Then
        '重置取消标志
        mCancelEnum = False
        RaiseEvent EnumFinished
    End If
    
   If rlngErrNum <> 0 Then
    RaiseEvent EnumError(parentNodes(), mvarRunningNum - 1, rlngErrNum, rstrErrDescr)
   End If
   'MsgBox CStr(rlngErrNum) + "@:" + Err.Description
   Debug.Print "<======mvarRunningNum"; mvarRunningNum
   Debug.Print rstrErrDescr
End Function

Function convertdata(ByVal hkey As Long, ByVal subkey As String, ByVal lType As Long) As String
        Dim sValue As String
        Dim keyV As String
        Dim lBuffer As Long, sBuffer As String, ldata As Long

         Select Case lType
           Case iREG_SZ
              lBuffer = 1024
              sBuffer = Space(lBuffer)
              If RegQueryValueEx(hkey, subkey, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
                 Err.Raise vbObjectError + 1, , "获取注册表值时出错1"
              End If
              sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
           Case iREG_EXPAND_SZ
              lBuffer = 1024
              sBuffer = Space(lBuffer)
              If RegQueryValueEx(hkey, subkey, 0, lType, ByVal sBuffer, lBuffer) <> ERROR_SUCCESS Then
                 Err.Raise vbObjectError + 1, , "获取注册表值时出错2"
              End If
              sValue = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
           Case iREG_DWORD
                lBuffer = 4
              If RegQueryValueEx(hkey, subkey, 0, lType, ldata, lBuffer) <> ERROR_SUCCESS Then
                 Err.Raise vbObjectError + 1, , "获取注册表值时出错3"
              End If
              sValue = ldata
           Case iREG_BINARY
                lBuffer = 4
              If RegQueryValueEx(hkey, subkey, 0, lType, ldata, lBuffer) <> ERROR_SUCCESS Then
                 Err.Raise vbObjectError + 1, , "获取注册表值时出错4"
              End If
              sValue = ldata
        End Select
        convertdata = sValue
End Function

Sub Class_Initialize()
    mCancelEnum = False
    mvarRunningNum = 0
    mvarHKEY_CURRENT_USER = "HKEY_CURRENT_USER"
    mvarHKEY_LOCAL_MACHINE = "HKEY_LOCAL_MACHINE"
    mvarHKEY_CLASSES_ROOT = "HKEY_CLASSES_ROOT"
    mvarHKEY_CURRENT_CONFIG = "HKEY_CURRENT_CONFIG"
    mvarHKEY_USERS = "HKEY_USERS"
    
End Sub
'放弃枚举
Sub CancelEnum()
 mCancelEnum = True
End Sub
'作用：删除注册表项（及子项）
'此函数为递归函数
'会多次引发DeletedNode事件
Public Function DeleteTreeKey(ByVal hkey As Long, ByVal subkey As String)
   Dim hSubKey As Long
   Const BUFFERLENTH = 1024
   
   Dim rlngErrNum As Long
   Dim rstrErrDescr As String
   
   On Error GoTo DeleteKeyErr
   
    If RegOpenKeyEx(hkey, subkey, 0, KEY_READ, hSubKey) <> ERROR_SUCCESS Then
        
        Err.Raise vbObjectError + 1, , "打开注册表时出错"
    End If
    Debug.Print "打开"; hSubKey, "subkey:"; subkey
    Debug.Print "====>"; subkey
    Dim LWT As FILETIME
    Dim NameMaxLenth As Long
    Dim nodeCount As Long, leafCount As Long '结点
    
    Dim sClass As String, lClass As Long
    Dim lValueMaxBytes As Long '结点值的最大字节数
   
    Debug.Print "查询:"; hSubKey, "subkey:"; subkey
    If RegQueryInfoKey(hSubKey, sClass, lClass, 0, nodeCount, 0, 0, leafCount, NameMaxLenth, lValueMaxBytes, 0, LWT) <> ERROR_SUCCESS Then
       Err.Raise vbObjectError + 1, , "查询注册表信息时出错"
    End If
        'Debug.Print keyPath, "数据类型：", lClass
    Debug.Print "检查是否有子目录"
    
    Dim deleted As Boolean
    deleted = False
    If nodeCount = 0 Then
        Debug.Print "准备删除:"; hSubKey, "subkey:"; subkey
        If RegDeleteKey(hSubKey, "") <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "删除注册表键时出错"
        Else
            deleted = True
            RaiseEvent DeletedNode(hSubKey, subkey)
            Debug.Print "已经删除:"; hSubKey, "subkey:"; subkey
        End If
        
    Else
        Dim dwIndex As Long
        Debug.Print "执行枚举"
        dwIndex = 0
        For dwIndex = nodeCount To 1 Step -1
        
            'Debug.Print "in:", dwIndex, nodeCount
            'RegEnumKeyEx(lhSubKey, i, sKeyName, lenKeyName, 0, vbNullString, 0, tFT)
            Dim sNodeKeyName As String, lenNodeKeyName As Long
            sNodeKeyName = String(BUFFERLENTH, Chr(0))
            lenNodeKeyName = Len(sNodeKeyName)
            sClass = String(BUFFERLENTH, Chr(0))
            lClass = Len(sClass)
            If RegEnumKeyEx(hSubKey, dwIndex - 1, sNodeKeyName, lenNodeKeyName, 0, sClass, lClass, LWT) <> ERROR_SUCCESS Then
                Err.Raise vbObjectError + 1, , "枚举注册表键时出错"
            End If
            
            DoEvents
            Debug.Print "执行回调start"; dwIndex, hSubKey, Left(sNodeKeyName, lenNodeKeyName)
            Call DeleteTreeKey(hSubKey, Left(sNodeKeyName, lenNodeKeyName))
            Debug.Print "执行回调end"; dwIndex, hSubKey, Left(sNodeKeyName, lenNodeKeyName)
            'lenKeyName会被修改
            lenNodeKeyName = BUFFERLENTH
        Next
    
    End If


    'Debug.Print "out:", dwIndex, nodeCount
    If Not deleted Then
        If RegDeleteKey(hSubKey, "") <> ERROR_SUCCESS Then
            Err.Raise vbObjectError + 1, , "删除注册表键时出错"
        Else
            RaiseEvent DeletedNode(hSubKey, subkey)
            Debug.Print "退出前已经删除:"; hSubKey, "subkey:"; subkey
        End If
    End If
    
   If RegCloseKey(hSubKey) <> ERROR_SUCCESS Then
      Err.Raise vbObjectError + 1, , "关闭注册表时出错"
   End If
   Debug.Print "关闭:"; hSubKey, "subkey:"; subkey
   Err.Clear
DeleteKeyErr:
   rlngErrNum = Err.Number
   rstrErrDescr = Err.Description
   If rlngErrNum <> 0 Then
    RaiseEvent DeleteError(hSubKey, subkey, rlngErrNum, rstrErrDescr)
   End If
   Debug.Print rstrErrDescr
   Debug.Print "<===="; subkey
End Function

封装使用

文章来源地址https://www.toymoban.com/news/detail-781292.html

Option Explicit
Dim WithEvents enumReg As CEnumReg

Dim sum As Long

Dim rlngErrNum As Long, rstrErrDescr As String

Dim exitApp As Boolean


Dim t As Integer
'开始按钮
Private Sub cmdClean_Click()
    'MsgBox (enumReg Is Nothing)
    If enumReg Is Nothing Then
        Set enumReg = New CEnumReg
        'MsgBox (enumReg Is Nothing)
    End If
    sum = 0
    
    'MsgBox CStr(enumReg.RunningNum)
    If enumReg.RunningNum <= 0 Then
        Call enumReg.EnumAll(Combo1.ItemData(Combo1.ListIndex), Trim(Text1.Text))
        Debug.Print "**********"
    Else
       Call enumReg.CancelEnum
    End If
    
End Sub


Private Sub cmdClear_Click()
 List1.Clear
End Sub

Private Sub enumReg_DeletedNode(ByVal hkey As Long, ByVal subkey As String)
    Dim k As String
    k = enumReg.GetRegKeyName(hkey)
    List1.AddItem ("已删除 " + k + "\" + subkey + " hkey:" + CStr(hkey))
End Sub

Private Sub enumReg_DeleteError(ByVal hkey As Long, ByVal subkey As String, ByVal errNum As Long, ByVal errDescr As String)
    List1.AddItem (CStr(hkey) + "\" + subkey + Chr(9) + "错误：" + errDescr + Chr(9) + CStr(errNum))
End Sub

Private Sub enumReg_EnumError(ByRef parentNodes() As String, ByVal parentNodeLevel As Long, ByVal errNum As Long, ByVal errDescr As String)
    Dim s As String, i As Long
    For i = 0 To parentNodeLevel
    
        s = s + parentNodes(i) + "\"
    Next
    List1.AddItem (s + Chr(9) + "错误：" + errDescr + Chr(9) + CStr(errNum))
End Sub

Private Sub enumReg_EnumFinished()
   If exitApp Then
    Unload Me
   Else
    Label2.Caption = "已完成"
   End If
End Sub

Private Sub enumReg_EnumLeaf(ByVal hkey As Long, ByRef parentNodes() As String, ByVal parentLevel As Long, ByVal subkey As String, _
                                ByVal keyName As String, keyValue As Variant, keyValueType As Long)
       Dim rtn As Long, newValue As String
       Dim i As Long, kpath As String
       
       For i = 0 To parentLevel
        kpath = kpath + "\" + parentNodes(i) + "\"
       Next
        Label2.Caption = kpath + Chr(9) + keyName + "=" + CStr(keyValue)
        
        Const s = "2345Pic"
        
        '键名含指定字符
        If InStr(1, CStr(keyName), s) Then
            
            If DeleteValue(hkey, "", keyName) Then
                List1.AddItem ("删除成功" + Chr(9) + kpath + Chr(9) + keyName)
            Else
                
                List1.AddItem ("删除失败：" + Chr(9) + kpath + Chr(9) + keyName)
            End If
        End If
        
       Select Case keyValueType
          Case iREG_NONE '默认
          
          Case iREG_SZ
             'lBuffer = LenB(keyValue)
                
                
                If InStr(1, CStr(keyValue), s) Then
                    newValue = Replace(CStr(keyValue), s, "Pic")
                    
                    Debug.Print "event:", kpath + "\" + subkey + "\", Chr(9), keyName + "=" + CStr(keyValue)
                    'SetValue函数是返 布尔值的
                    If SetValue(hkey, keyName, "", keyValueType, newValue) Then
                       Debug.Print "修改注册表时成功", "原值:", CStr(keyValue), "新值:", newValue
                       List1.AddItem (kpath + "\" + "    原值：" + CStr(keyValue) + "    新值：" + newValue)
                    End If
                    
                    sum = sum + 1

                Else
                    'List1.AddItem (kpath + Chr(9) + keyName + "=" + CStr(keyValue))

                End If
                
                  Const s1 = "看图王 "
                  
                If InStr(1, CStr(keyValue), s1) Then
                
                    newValue = Replace(CStr(keyValue), s1, "")
                    'SetValue函数是返 布尔值的
                    If SetValue(hkey, "", "", keyValueType, newValue) Then
                       Debug.Print "修改注册表时成功", "原值:", CStr(keyValue), "新值:", newValue
                       List1.AddItem (kpath + "\" + subkey + "    原值：" + CStr(keyValue) + "    新值：" + newValue)
                    End If
                    
                    sum = sum + 1
                End If
          Case iREG_EXPAND_SZ
             'lBuffer = LenB(sValue)
    
          Case iREG_DWORD
             'lBuffer = 4
    
          Case iREG_BINARY
             'lBuffer = 4
    
          Case Else
             'Err.Raise vbObjectError + s1, , "不支持该参数类型"
             Debug.Print "不支持该参数类型" + CStr(keyValueType)
       End Select
   

    'Debug.Print "共计:", sum, "条"
    Label1.Caption = "共计:" + CStr(sum) + "条"
    Debug.Print "leaf event:", kpath + "\" + subkey + "\", Chr(9), keyName + "=" + CStr(keyValue)
End Sub

Private Sub enumReg_EnumNode(ByVal hkey As Long, ByRef parentNodes() As String, ByVal parentLevel As Long, ByVal subkey As String)
    Dim fullkeys As String, i As Long
    
    For i = 0 To parentLevel
     fullkeys = fullkeys + "\" + parentNodes(i)
    Next
    Debug.Print "node event:", fullkeys, CStr(subkey)
    Debug.Print "node hkey:", hkey, "subkey:", subkey
           Dim rtn As Long, newValue As String
       Label2.Caption = fullkeys + "\" + subkey
       Select Case iREG_SZ
          Case iREG_NONE '默认
          
          Case iREG_SZ
             'lBuffer = LenB(keyValue)
                Const s = "2345Pic"  '垃圾软件之王2345   
                If InStr(1, subkey, s) Then
                    newValue = Replace(subkey, s, "Pic")
                    
                    Debug.Print "event:", fullkeys + "\", 0, subkey
                    'SetValue函数是返 布尔值的
                    List1.AddItem ("准备删除键：" + fullkeys + "\" + subkey)
                    Call enumReg.DeleteTreeKey(hkey, subkey)
'                    If RegRenameKey(hkey, subkey, newValue) = 0 Then
'                       Debug.Print "修改注册表时成功", "原值:", subkey, "新值:", newValue
'                       List1.AddItem (kpath + "\" + subkey + "    原值：" + subkey + "    新值：" + newValue)
'                    End If
                    
                    sum = sum + 1

                End If
                
                  Const s1 = "看图王 "
                  
                If InStr(1, subkey, s1) Then
                
                    newValue = Replace(subkey, s1, "")
                    'SetValue函数是返 布尔值的
                    'Call enumReg.DeleteTreeKey(hkey, subkey)
                       'Debug.Print "修改注册表时成功", "原值:", subkey, "新值:", newValue
                       'List1.AddItem (kpath + "\" + subkey + "    原值：" + subkey + "    新值：" + newValue)

                    
                    sum = sum + 1
                End If
          Case iREG_EXPAND_SZ
             'lBuffer = LenB(sValue)
    
          Case iREG_DWORD
             'lBuffer = 4
    
          Case iREG_BINARY
             'lBuffer = 4
    
          Case Else
             'Err.Raise vbObjectError + s1, , "不支持该参数类型"
             Debug.Print "不支持该参数类型" + 0
       End Select
   

    Debug.Print "共计:", sum, "条"
    Label1.Caption = "共计:" + CStr(sum) + "条"
    
    
End Sub

Private Sub Form_Load()

   Combo1.AddItem "HKEY_CLASSES_ROOT"
   Combo1.ItemData(Combo1.NewIndex) = &H80000000
   Combo1.AddItem "HKEY_CURRENT_USER"
   Combo1.ItemData(Combo1.NewIndex) = &H80000001
   Combo1.AddItem "HKEY_LOCAL_MACHINE"
   Combo1.ItemData(Combo1.NewIndex) = &H80000002
   Combo1.AddItem "HKEY_USERS"
   Combo1.ItemData(Combo1.NewIndex) = &H80000003
   Combo1.AddItem "HKEY_CURRENT_CONFIG"
   Combo1.ItemData(Combo1.NewIndex) = &H80000005
   
   Combo1.ListIndex = 0
    
  'Call test(iHKEY_CLASSES_ROOT, ".3g2")
End Sub


'删除按钮
Private Sub Command1_Click()
Debug.Print "---------------------------------------------------------------------------------------------------------"
    If enumReg Is Nothing Then
        Set enumReg = New CEnumReg
    End If
    If Len(Trim(Text1.Text)) <= 0 Then Exit Sub
    Call enumReg.DeleteTreeKey(Combo1.ItemData(Combo1.ListIndex), Trim(Text1.Text))

    
    
End Sub



Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
 
 If Not enumReg Is Nothing Then
    Call enumReg.CancelEnum
    exitApp = True
 End If
End Sub

Private Sub Form_Resize()
    List1.Width = Me.Width - 4 * List1.Left
    Label2.Width = List1.Width
    
    List1.Height = Me.Height - List1.Top - cmdClear.Height - 500
    
    cmdClear.Top = List1.Top + List1.Height
    cmdClear.Left = Me.Width - cmdClear.Width - 3 * List1.Left
End Sub

到了这里，关于VB6 注册表的递归访问与面象对象模块化封装的文章就介绍完了。如果您还想了解更多内容，请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章，希望大家以后多多支持TOY模板网！