突然翻到这个东西,似乎之前没发过,就发来了。

代码:
Attribute VB_Name = "mHiveControl"

'By 炉子[0GiNr]
'http://hi.baidu.com/breakinglove_
'http://0ginr.com

Option Explicit

Public Declare Function RegRestoreKey Lib "advapi32.dll" Alias "RegRestoreKeyA" ( _
         ByVal hKey As Long, _
         ByVal lpFile As String, _
         ByVal dwFlags As RegRestoreFlags) As Long
Public Declare Function RegSaveKeyEx Lib "advapi32.dll" Alias "RegSaveKeyExA" ( _
         ByVal hKey As Long, _
         ByVal lpFile As String, _
         ByVal lpSecurityAttributes As Long, _
         ByVal dwFlags As RegSaveExFlags) As Long
Public Enum RegKeys
        HKEY_CLASSES_ROOT = &H80000000
        HKEY_CURRENT_USER = &H80000001
        HKEY_LOCAL_MACHINE = &H80000002
        HKEY_USERS = &H80000003
        HKEY_CURRENT_CONFIG = &H80000005
End Enum
Public Enum RegRestoreFlags
        REG_FORCE_RESTORE = &H8
        REG_WHOLE_HIVE_VOLATILE = &H1
End Enum
Public Enum RegSaveExFlags
        REG_STANDARD_FORMAT = &H1
        REG_LATEST_FORMAT = &H2
        REG_NO_COMPRESSION = &H4
End Enum
Public Type LARGE_INTEGER
        LowPart As Long
        HighPart As Long
End Type
Public Type RegfBlock
        dwSignature As Long '字符串 - "regf" = 0x66676572
        dwUnknown1 As Long '未知
        dwUnknown2 As Long '总是为 0x00000004
        liLastEdit As LARGE_INTEGER 'NT 时间格式
        dwNumber1 As Long '恒为1
        dwNumber2 As Long '恒为3
        dwNumber3 As Long '恒为0
        dwNumber4 As Long '恒为1 - 或许这个1301是版本1.3.0.1?
        dwOffsetOfFirstKeyRecord As Long '第一个键纪录的偏移
        dwBlockSize As Long '数据块大小(文件大小-4kb)
        dwNumber5 As Long '恒为1
        bytUnknownData(To &H1CCAs Byte '无需分析
        dwSum As Long '从 0x00000000 至 0x000001FB 的所有DWORD的数据总和
End Type

Public Type UnkownDataAfterRegfBlock '紧随 RegfBlock 之后
        bytReserved(To &HE00As Byte '未知
End Type

Public Type HBinHeader
        dwSignature As Long '字符串 - "hbin" = 0x6E696268
        dwOffsetFromFirstHBinRecord As Long '第一个 Hbin 记录的偏移
        dwOffsetFromNextHBinRecord As Long '下一个 Hbin 记录的偏移
        dwUnknownData(To &H10As Byte
        dwBlockSize As Long 'Hbin 记录长度
End Type

Public Type HBinData '如果这个段是一个负值(第 31 位被置1),则这个块是空的,并且长度被置为负的块大小
        dwDataBlockSize As Long
        szData() As Byte '长度取决于 dwDataBlockSize
End Type

Public Type NkRecord 'NameKey
        wSignature As Integer '字符串 - "nk" = 0x6B6E
        wKeyType As Integer '根键为 0x2C,否则为0x20
        liLastEdit As LARGE_INTEGER 'NT 时间格式
        bytUnknowData(To &H4As Byte
        dwOffsetOfParentKey As Long '父键的偏移
        dwSubKeyNumber As Long '子键数目
        bytUnknowData2(To &H4As Byte
        dwOffsetOfSubKeyLfRecords As Long '子键的 Lf 记录的偏移
        bytUnknowData3(To &H4As Byte
        dwValuesNumber As Long '项的数目
        dwOffsetOfValueList As Long 'NkRecordValueList 的偏移
        dwOffsetOfSkRecord As Long 'Sk 记录的偏移
        dwOffsetOfClassName As Long '类名的偏移(???)
        bytUnused(To &H10As Byte
        dwUnused As Long '无用数据
        wNameLength As Integer '项名长度
        wClassNameLength As Integer '类名的长度(???)
        szKeyName(To 1As Byte '长度取决于 dwNameLength
End Type

Public Type NkRecordValueList
        dwValueOffset(1As Long '数组数量取决于 dwValuesNumber
End Type

Public Type VkRecord 'ValueKey
        wSignature As Integer '字符串 - "vk" = 0x6B76
        wNameLength As Integer '项名长度
        dwDataLength As Long '数据长度 - 如果 dwDataLength <=4 那么这个值的数据就是该项的数据 (DWORD);如果为 0 那么这个项无数据
        dwDataOffset As Long '数据偏移
        dwValueType As Long '数据类别 - 数据类别见 DataTypes
        wFlags As Integer '如果第 0 位被置1,那么这条数据是有名称的,否则意味着这条数据是无名称的(“默认”)
        wUnused As Integer '无用数据
        szName(To 1As Byte
End Type

Public Enum DataTypes
        REG_SZ = &H1 '字符串 UNICODE
        REG_EXPEND_SZ = &H2 '可展开的字符串(使用环境变量,例如 "%SystemRoot%\system32") UNICODE
        REG_BINARY = &H3 '二进制数据
        REG_DWORD = &H4 'DWORD
        REG_MULTI_SZ = &H7 '多个字符串,使用 vbNullChar 分隔 UNICODE
        REG_UNKNOWN = &HFFFFFFFF
End Enum

Public Type HashRecord 'Lf 记录的哈希记录
        dwRecordOffset As Long '所属的 Lf 记录的偏移
        szKeyName(To 4As Byte '键名的前4字节 如果修改了键名,这个也需要修改
End Type

Public Type LfRecord
        wSignature As Integer '字符串 - "lf" = 0x666C
        wKeyNumber As Integer '键的数目
        dwHashRecord(To 1As HashRecord
End Type

Public Type SkRecord 'SecurityKey
        wSignature As Integer '字符串 - "sk" = 0x6B73
        wUnused As Integer
        dwPreviousSkRecordOffset As Long '前一个Sk记录的偏移
        dwNextSkRecordOffset As Long '后一个Sk记录的偏移
        dwUsageCounter As Long '使用计数 (???)
        dwRecordSize As Long 'Sk记录的字节数
        '剩余部分为权限设置数据
End Type

Public Declare Function SafeCopyMemory _
               Lib "NTDLL.DLL" Alias "ZwWriteVirtualMemory" _
                               (ByVal ProcessHandle As Long, _
                                ByVal pDest As Long, _
                                ByVal pSrc As Long, _
                                ByVal NumberOfBytesToCopy As Long, _
                                ByRef NumberOfBytesCopied As LongAs Long
Public Const ZwGetCurrentProcess As Long = -'//0xFFFFFFFF
Dim m_pHive As Long
Dim m_RegfBlock As RegfBlock, m_HBinHeader As HBinHeader, m_RootNkRecord As NkRecord
Dim m_RaisedErr As Boolean
Dim m_pRootNk As Long
Private Const GlobalOffset As Long &H1004
Private Const RegDefault As String = "(Default)"

Public Sub dbg()
        Dim As NkRecord
        Debug.Print Hex(LenB(a))
End Sub

'hHive should be the base of the hive file in memory
Public Function PreProcessHive(ByVal hHive As LongAs Boolean
        Dim st As Long
        Dim hBase As Long
        Dim unKnownData As UnkownDataAfterRegfBlock
        
        'save hive pointer
        m_pHive = hHive
        
        hBase = hHive
        
        'read regf block
        st = CopyMemory(VarPtr(m_RegfBlock), hBase, LenB(m_RegfBlock))
        If (Not st) Then GoTo InitFaild_
        
        'read hbin header
        hBase = hBase + LenB(m_RegfBlock) + LenB(unKnownData)
        st = CopyMemory(VarPtr(m_HBinHeader), hBase, LenB(m_HBinHeader))
        If (Not st) Then GoTo InitFaild_
        
        'read root nk header
        Dim HbData As HBinData
        st = CopyMemory(VarPtr(HbData), hBase + LenB(m_HBinHeader), LenB(HbData))
        If (Not st) Then GoTo InitFaild_
        hBase = hBase + GetHBinSize(HbData)
        st = CopyMemory(VarPtr(m_RootNkRecord), hBase, LenB(m_RootNkRecord))
        m_pRootNk = hBase
        If (Not st) Then GoTo InitFaild_
        
        'return
        PreProcessHive = True
        Exit Function
InitFaild_:
        PreProcessHive = False
End Function

'这两段是测试用的。
Public Sub NOP()
        NOP1 (m_pRootNk)
        
        DoEvents
End Sub

Public Sub NOP1(ByVal lpNk As Long)
        'MsgBox GetKeyNameByPointer(m_pRootNk)
        Dim szReturn As String
        Dim As Long, J As Long
        Dim nks() As Long
        Dim lfs() As Long
        lfs = GetSubKeyListNkPointers(lpNk)
        For I = LBound(lfs) To UBound(lfs)
                Dim vks() As Long
                vks = GetValueListVkPointers(lfs(I))
                szReturn = szReturn & "KeyName:" & GetKeyNameByPointer(lfs(I)) & vbCrLf
                If (Not m_RaisedErr) Then
                        For J = LBound(vks) To UBound(vks)
                                If (vks(J)) = Then Exit For
                                Dim dt As DataTypes
                                dt = GetValueTypeByPointer(vks(J))
                                Dim ret() As Byte
                                ret = GetValueDataByPointer(vks(J), dt)
                                If dt = REG_DWORD Then
                                        Dim As Long
                                        Call CopyMemory(VarPtr(K), VarPtr(ret(1)), 4)
                                        szReturn = szReturn & vbTab & GetValueNameByPointer(vks(J)) & vbTab & K & vbCrLf
                                ElseIf dt = REG_SZ Then
                                        Dim szValue As String: szValue = ret
                                        szReturn = szReturn & vbTab & GetValueNameByPointer(vks(J)) & vbTab & szValue & vbCrLf
                                Else
                                        szReturn = szReturn & vbTab & GetValueNameByPointer(vks(J)) & vbTab & "(Unsupportted value type = " & dt & ")" & vbCrLf
                                End If
                                DoEvents
                        Next

                Else
                        ClearError
                End If
        Next
        DoEvents
        WriteFile App.Path & "\Output.txt", StrConv(szReturn, vbFromUnicode)
End Sub

'get the size of the HBIN block
Private Function GetHBinSize(ByRef pHBinInfo As HBinData) As Long
        Dim HBHdrInfo As HBinHeader
        If (pHBinInfo.dwDataBlockSize And &H80000000Then
                'the 31bit of 0x80000000 is 1, others are 0
                GetHBinSize = LenB(HBHdrInfo) + LenB(pHBinInfo.dwDataBlockSize)
                Exit Function
        Else
                GetHBinSize = LenB(HBHdrInfo) + LenB(pHBinInfo.dwDataBlockSize) + pHBinInfo.dwDataBlockSize
        End If
End Function

'get key name from NK record
Public Function GetKeyNameByPointer(ByVal pNkRecord As LongAs String
        Dim retByt() As Byte
        Dim szRetKeyName As String
        Dim Offset As Long
        Dim NkRec As NkRecord
        Dim st As Boolean
        ReDim pVkRec(To 1)
        st = CopyMemory(VarPtr(NkRec), pNkRecord, LenB(NkRec))
        If (Not st) Then GoTo ExitFunc_
        With NkRec
                If (.wNameLength = 0Then GoTo ExitFunc_
                ReDim retByt(.wNameLength)
                Offset = VarPtr(.szKeyName(1)) - VarPtr(NkRec) + pNkRecord  ' - m_pHive
                st = CopyMemory(VarPtr(retByt(LBound(retByt))), Offset, .wNameLength)
                If (Not st) Then GoTo ExitFunc_
                szRetKeyName = StrConv(retByt, vbUnicode)
                If (InStr(szRetKeyName, vbNullChar)) Then szRetKeyName = Left(szRetKeyName, InStr(szRetKeyName, vbNullChar) - 1)
        End With
FinishFunc_:
        Erase retByt
        GetKeyNameByPointer = szRetKeyName
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get key name from NK record
Public Function GetValueNameByPointer(ByVal pVkRecord As LongAs String
        Dim retByt() As Byte
        Dim szRetName As String
        Dim Offset As Long
        Dim VkRec As VkRecord
        Dim st As Boolean
        ReDim pVkRec(To 1)
        st = CopyMemory(VarPtr(VkRec), pVkRecord, LenB(VkRec))
        If (Not st) Then GoTo ExitFunc_
        With VkRec
                If (.wNameLength = 0Then szRetName = RegDefault: GoTo FinishFunc_
                ReDim retByt(.wNameLength)
                Offset = VarPtr(.szName(1)) - VarPtr(VkRec) + pVkRecord  ' - m_pHive
                st = CopyMemory(VarPtr(retByt(LBound(retByt))), Offset, .wNameLength)
                If (Not st) Then GoTo ExitFunc_
                szRetName = StrConv(retByt, vbUnicode)
                If (InStr(szRetName, vbNullChar)) Then szRetName = Left(szRetName, InStr(szRetName, vbNullChar) - 1)
        End With
FinishFunc_:
        Erase retByt
        GetValueNameByPointer = szRetName
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get value list, pNkRecord should be the NK record to list, return val is a array pointer to VK record
Public Function GetValueListVkPointers(ByVal pNkRecord As LongAs Long()
        Dim pVkRec() As Long
        Dim NkRec As NkRecord
        Dim dwNumber As Long
        Dim lOffset As Long
        Dim st As Boolean
        ReDim pVkRec(To 1)
        st = CopyMemory(VarPtr(NkRec), pNkRecord, LenB(NkRec))
        If (Not st) Then GoTo ExitFunc_
        With NkRec
                dwNumber = .dwValuesNumber
                If (dwNumber = 0Then GoTo ExitFunc_
                ReDim pVkRec(To dwNumber)
                st = CopyMemory(VarPtr(lOffset), VarPtr(.dwOffsetOfValueList) - VarPtr(NkRec) + pNkRecord, LenB(lOffset))
                If (Not st) Then GoTo ExitFunc_
                lOffset = lOffset + m_pHive + GlobalOffset
                st = CopyMemory(VarPtr(pVkRec(LBound(pVkRec))), lOffset, dwNumber * LenB(pVkRec(LBound(pVkRec))))
                If (Not st) Then GoTo ExitFunc_
        End With
        
        'add offset to them :)
        Dim As Long
        For I = LBound(pVkRec) To UBound(pVkRec)
                pVkRec(I) = pVkRec(I) + GlobalOffset + m_pHive
        Next
FinishFunc_:
        GetValueListVkPointers = pVkRec
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get sub-key list, pNkRecord should be the NK record to list, return val is a array pointer to HASH record
Public Function GetSubKeyListNkPointers(ByVal pNkRecord As LongAs Long()
        Dim pNkRec() As Long
        Dim NkRec As NkRecord
        Dim LfRec As LfRecord
        Dim HashRec() As HashRecord
        Dim st As Boolean
        ReDim pNkRec(To 1)
        st = CopyMemory(VarPtr(NkRec), pNkRecord, LenB(NkRec))
        If (Not st) Then GoTo ExitFunc_
        With NkRec
                Dim dwNumber As Long
                Dim dwPosi As Long
                dwNumber = .dwSubKeyNumber
                If (dwNumber = 0Then GoTo ExitFunc_
                ReDim HashRec(To dwNumber)
                st = CopyMemory(VarPtr(dwPosi), VarPtr(.dwOffsetOfSubKeyLfRecords) - VarPtr(NkRec) + pNkRecord, LenB(dwPosi))
                If (Not st) Then GoTo ExitFunc_
                dwPosi = dwPosi + GlobalOffset + m_pHive
                st = CopyMemory(VarPtr(LfRec), dwPosi, LenB(LfRec))
                If (Not st) Then GoTo ExitFunc_
                dwPosi = dwPosi + VarPtr(LfRec.dwHashRecord(1)) - VarPtr(LfRec)
                st = CopyMemory(VarPtr(HashRec(LBound(HashRec))), dwPosi, dwNumber * LenB(HashRec(LBound(HashRec))))
                If (Not st) Then GoTo ExitFunc_
        End With
        
        'calc NK record address
        Dim As Long
        ReDim pNkRec(To dwNumber)
        For I = LBound(pNkRec) To UBound(pNkRec)
                pNkRec(I) = HashRec(I).dwRecordOffset + GlobalOffset + m_pHive
        Next
FinishFunc_:
        GetSubKeyListNkPointers = pNkRec
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get NK record pointer by HASH record
Public Function GetKeyNkRecordPointer(ByVal pHashRecord As LongAs Long
        Dim ret As Long
        Dim HashRec As HashRecord
        Dim st As Boolean
        st = CopyMemory(VarPtr(HashRec), pHashRecord, LenB(HashRec))
        If (Not st) Then GoTo ExitFunc_
        With HashRec
                ret = .dwRecordOffset + GlobalOffset + m_pHive
        End With
FinishFunc_:
        GetKeyNkRecordPointer = ret
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get key value by VK record
Public Function GetValueDataByPointer(ByVal pVkRecord As LongByVal dwValueType As DataTypes) As Byte()
        Dim ret() As Byte
        Dim VkRec As VkRecord
        Dim lOffset As Long
        Dim st As Boolean
        ReDim ret(To 1)
        st = CopyMemory(VarPtr(VkRec), pVkRecord, LenB(VkRec))
        If (Not st) Then ReDim ret(To 1): GoTo ExitFunc_
        With VkRec
                lOffset = .dwDataOffset + GlobalOffset + m_pHive
                Select Case dwValueType
                        Case REG_DWORD
                                ReDim ret(To LenB(.dwDataOffset))
                                        st = CopyMemory(VarPtr(ret(LBound(ret))), VarPtr(.dwDataOffset), UBound(ret) - LBound(ret) + 1)
                        Case REG_SZ
                                If (.dwDataOffset = 0Then GoTo ExitFunc_
                                ReDim ret(To .dwDataLength)
                                        st = CopyMemory(VarPtr(ret(LBound(ret))), lOffset, UBound(ret) - LBound(ret) + 1)
                        Case Else
                                'unsupportted.
                                If (.dwDataOffset = 0Then GoTo ExitFunc_
                                ReDim ret(To .dwDataLength)
                                        st = CopyMemory(VarPtr(ret(LBound(ret))), lOffset, UBound(ret) - LBound(ret) + 1)

                End Select
                                
                'If (.dwDataOffset < 5) Then GoTo ExitFunc_
                'lOffset = .dwDataOffset + GlobalOffset + m_pHive
                'ReDim ret(1 To .dwDataLength)
                'st = CopyMemory(VarPtr(ret(LBound(ret))), lOffset, .dwDataLength)
                'If (Not st) Then ReDim ret(1 To 1): GoTo ExitFunc_
        End With
FinishFunc_:
        GetValueDataByPointer = ret
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

'get key value by VK record
Public Function GetValueTypeByPointer(ByVal pVkRecord As LongAs DataTypes
        Dim VkRec As VkRecord
        Dim st As Boolean
        Dim ret As DataTypes
        ret = REG_UNKNOWN
        st = CopyMemory(VarPtr(VkRec), pVkRecord, LenB(VkRec))
        If (Not st) Then GoTo ExitFunc_
        With VkRec
                ret = .dwValueType
        End With
FinishFunc_:
        GetValueTypeByPointer = ret
        Exit Function
ExitFunc_:
        m_RaisedErr = True
        'Resume FinishFunc_
End Function

Public Sub ClearError()
        m_RaisedErr = False
End Sub

'return TRUE if the operation is successful
Public Function NT_SUCCESS(ByVal Status As LongAs Boolean
        NT_SUCCESS = (Status >= 0)
End Function

'copy data
Public Function CopyMemory(ByVal pDst As LongByVal pSrc As LongByVal nLength As LongAs Boolean
        Dim st As Long
        st = SafeCopyMemory(ZwGetCurrentProcess, pDst, pSrc, nLength, ByVal 0)
        CopyMemory = NT_SUCCESS(st)
End Function