'请放3个CommandBox一个ListBox於form上

Option Explicit
'
Private Sub Form_Load()
    Dim hKey As Long, ret As Long

    ret = SetDefaultValue(HKEY_LOCAL_MACHINE, "SOFTWARE\kj\Registry", _
                       "kj Registry Master")
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\kj\Registry", hKey)

    ret = SetValue(hKey, "StringData", REG_SZ, "这是字串")
    ret = SetValue(hKey, "MultiString", REG_MULTI_SZ, "字串一" + Chr(0) _
          + "字串二" + Chr(0))
    ret = SetValue(hKey, "LongData", REG_DWORD, 99999)
    ret = SetValue(hKey, "BinaryData", REG_BINARY, _
                    Array(&H11, &H22, &H33, &H44, &HAA, &HBB, &HCC, &HDD), 8)
    Call RegCloseKey(hKey)
    MsgBox "已写入资料到登录资料库中，您可以开启 RegEdit 加以检查！"
End Sub

Private Sub Command1_Click() ' 显示所有 Value
    Dim Index As Long, ret As Long, hKey As Long
    Dim bArr() As Byte, Name As String, vType As Long

    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\kj\Registry", hKey)
    ret = GetValueByIndex(hKey, Index, Name, bArr, vType)
    While ret
        If Len(Name) = 0 Then Name = "(预 设 值)"
        List1.AddItem Name & vbTab & ValueOutput(bArr, vType)
        Index = Index + 1
        ret = GetValueByIndex(hKey, Index, Name, bArr, vType)
    Wend
    Call RegCloseKey(hKey)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim Index As Long, ret As Long, hKey As Long
    Dim bArr() As Byte, Name As String, vType As Long

    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\kj\Registry", hKey)
    ret = GetValueByIndex(hKey, Index, Name, bArr, vType)
    While ret
        Call RegDeleteValue(hKey, Name)
        ' 不可以执行 Index = Index + 1，因为 Index = 0 的 Value 已删除，
        ' 後面的 Index 向前递减，所以 Index = 0 又可以读到 Value，
        ' 其实在这一个 While 回圈中，您可以将 Index 变数改成 0
        ret = GetValueByIndex(hKey, Index, Name, bArr, vType)
    Wend
    Call RegCloseKey(hKey)
    MsgBox "kj\Registry 的 Value 已删除，利用 RegEdit 检查时，记得要先执行功能的「检视／重新整理」！"
End Sub

Function ValueOutput(bArr() As Byte, ByVal vType As Long) As String
    Dim S As String, S2 As String, length As Integer, L As Long
    Dim i As Integer, sArr() As String

    Select Case vType
        Case REG_SZ, REG_EXPAND_SZ
            ByteArrayToString bArr, S

            ' 呼叫 ExpandEnvironmentStrings
            S2 = String(Len(S) + 256, Chr(0))
            length = ExpandEnvironmentStrings(S, S2, Len(S2))
            S = Left(S2, length - 1)
            ValueOutput = "Type=String, Data=" & S

        Case REG_MULTI_SZ
            ByteArrayToMultiString bArr, sArr
            ValueOutput = "Type=MultiString, Data="
            For i = LBound(sArr) To UBound(sArr)
                ValueOutput = ValueOutput & sArr(i) & ", "
            Next i

        Case REG_DWORD, REG_DWORD_BIG_ENDIAN
            ByteArrayToLong bArr, L
            ValueOutput = "Type=Long, Data=" & L

        Case REG_BINARY
            ValueOutput = "Type=Byte Array, Data="
            For i = LBound(bArr) To UBound(bArr)
                ValueOutput = ValueOutput + Format(Hex(bArr(i)), "00")
            Next i
    End Select
End Function

Private Sub Command2_Click()
    Unload Me
    End
End Sub


Private Sub Command3_Click()
Dim hKey As Long, resu As Long
Dim aa As Boolean
Dim bytary() As Byte
Dim str5 As String
resu = RegOpenKey(HKEY_LOCAL_MACHINE, _
    "SOFTWARE\Microsoft\Windows\CurrentVersion", hKey)
aa = GetValue(hKey, "ProductId", bytary, REG_SZ)
Call ByteArrayToString(bytary, str5)
Debug.Print str5
Call RegCloseKey(hKey)
End Sub

'以下程式在registry.bas
'这是一个十分有用的函式库，而且原作者将之整理得相当好。
Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

' Registry API 宣告
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpc
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
Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As
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 ' mo
Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) 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, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData 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, lpData As Any, ByVal cbData As Long) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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

' 其他相关的 API 宣告
Declare Function ExpandEnvironmentStrings Lib "KERNEL32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Option Explicit

Enum RootKey
    HKEY_CLASSES_ROOT = &H80000000
    HKEY_CURRENT_USER = &H80000001
    HKEY_LOCAL_MACHINE = &H80000002
    HKEY_USERS = &H80000003
    HKEY_PERFORMANCE_DATA = &H80000004
    HKEY_CURRENT_CONFIG = &H80000005
    HKEY_DYN_DATA = &H80000006
End Enum

Enum ErrorCode
    ERROR_SUCCESS = 0&
    ERROR_MORE_DATA = 234&
End Enum

Enum ValueType
    REG_NONE = 0
    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_DWORD_BIG_ENDIAN = 5
    REG_MULTI_SZ = 7
End Enum
'取得取个subkey的Default值
Function GetDefaultValue(ByVal hKey As Long, ByVal Subkey As String, Value As String) As Boolean
    Dim ret As Long, lenS As Long, S As String

    ret = RegQueryValue(hKey, Subkey, "", lenS)
    If ret <> 0 And ret <> ERROR_MORE_DATA Then
        GetDefaultValue = False
        Exit Function
    End If
    S = String(lenS, Chr(0))
    ret = RegQueryValue(hKey, Subkey, S, lenS)
    If ret <> 0 Then
        GetDefaultValue = False
        Exit Function
    End If
    Value = Left(S, lenS - 1)
    GetDefaultValue = True
End Function

Function GetValue(ByVal hKey As Long, ByVal ValueName As String, Value() As Byte, vType As ValueType) As Boolean
    Dim ret As Long, length As Long, i As Integer

    ret = RegQueryValueEx(hKey, ValueName, 0&, REG_BINARY, 0&, length)
    If ret = 0 Or ret = ERROR_MORE_DATA Then
        ReDim Value(0 To length - 1)
        vType = REG_BINARY
        ret = RegQueryValueEx(hKey, ValueName, 0&, vType, Value(0), length)
        If ret = 0 Then GetValue = True
        If vType = REG_SZ Or vType = REG_EXPAND_SZ Or vType = REG_MULTI_SZ Then
            ReDim Preserve Value(0 To length - 2)
        End If
    End If
End Function

Function GetValueByIndex(ByVal hKey As Long, ByVal Index As Long, Name As String, Value() As Byte, vType As Long) As Boolean
    Dim ret As Long, lenName As Long, lenData As Long

    ReDim Value(0) As Byte
    ret = RegEnumValue(hKey, Index, "", 0&, 0&, 0&, Value(0), lenData)
    If ret = 0 Or ret = ERROR_MORE_DATA Then
        ReDim Value(0 To lenData - 1) As Byte
        lenName = 256 ' Name 最长为 255, 需加上 0, 成为 256
        Name = String(lenName, Chr(0)) '  Name 非 self-Correcting 叁数
        ret = RegEnumValue(hKey, Index, Name, lenName, 0&, vType, Value(0), lenData)
        If ret = 0 Then
            GetValueByIndex = True
            Name = Left(Name, lenName) ' 不含 Chr(0)
        End If
    End If
End Function

Function GetSubkeyByIndex(ByVal hKey As Long, ByVal Index As Long, KeyName As String) As Boolean
    Dim ret As Long, Name As String, length As Long

    Name = String(256, Chr(0))
    ret = RegEnumKey(hKey, Index, Name, 256)
    If ret = 0 Then
        KeyName = Left(Name, InStr(Name, Chr(0)) - 1) ' 不含 Chr(0)
        GetSubkeyByIndex = True
    End If
End Function

Function SetDefaultValue(ByVal hKey As Long, ByVal Subkey As String, ByVal Value As String) As Boolean
    Dim ret As Long, lenS As Long, S As String

    ret = RegSetValue(hKey, Subkey, REG_SZ, Value, LenB(StrConv(Value, vbFromUnicode)) + 1)
    SetDefaultValue = (ret = 0)
End Function

Function SetValue(ByVal hKey As Long, ByVal ValueName As String, ByVal vType As Long, Value As Variant, Optional ByVal lenValue As Integer) As Boolean
    Dim ret As Long, bArr() As Byte

    On Error GoTo ErrorExit
    Select Case vType
        Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
            ret = RegSetValueEx(hKey, ValueName, 0&, vType, ByVal CStr(Value), LenB(StrConv(Value, vbFromUnicode)) + 1)
        Case REG_DWORD, REG_DWORD_BIG_ENDIAN
            ret = RegSetValueEx(hKey, ValueName, 0&, vType, CLng(Value), 4)
        Case REG_BINARY
            Dim i As Integer
            ReDim bArr(0 To lenValue - 1)
            For i = 0 To lenValue - 1
                bArr(i) = Value(i)
            Next
            ret = RegSetValueEx(hKey, ValueName, 0&, vType, bArr(0), lenValue)
    End Select
    SetValue = (ret = 0)
ErrorExit:
End Function

Function SetBinaryValue(ByVal hKey As Long, ByVal ValueName As String, ByVal vType As Long, Value() As Byte, ByVal lenValue As Long) As Boolean
    Dim ret As Long

    ret = RegSetValueEx(hKey, ValueName, 0&, vType, Value(0), lenValue)
    SetBinaryValue = (ret = 0)
End Function

Sub ByteArrayToString(bArray() As Byte, S As String)
    S = StrConv(bArray, vbUnicode)
End Sub

Sub StringToByteArray(S As String, bArray() As Byte)
    bArray = StrConv(S + Chr(0), vbFromUnicode)
End Sub

Sub ByteArrayToMultiString(bArray() As Byte, S() As String)
    Dim Stemp As String, count As Integer, pos As Integer, idx As Integer

    Stemp = StrConv(bArray, vbUnicode)
    pos = InStr(Stemp, Chr(0))
    While pos > 0
        count = count + 1
        pos = InStr(pos + 1, Stemp, Chr(0))
    Wend
    count = count - 1 ' 最後的字元是 Chr(0)+Chr(0)，所以减一

    ReDim S(0 To count - 1)
    For idx = 0 To count - 1
        pos = InStr(Stemp, Chr(0))
        S(idx) = Left(Stemp, pos - 1)
        Stemp = Mid(Stemp, pos + 1)
    Next
    Exit Sub
End Sub

Sub MultiStringToByteArray(S() As String, bArray() As Byte)
    Dim mS As String, i As Integer

    For i = LBound(S) To UBound(S)
        mS = mS + S(i) + Chr(0)
    Next i
    mS = mS + Chr(0)

    bArray = StrConv(mS, vbFromUnicode)
End Sub

Sub ByteArrayToLong(bArray() As Byte, vLong As Long)
    RtlMoveMemory vLong, bArray(0), 4
End Sub

Sub LongToByteArray(vLong As Long, bArray() As Byte)
    RtlMoveMemory bArray(0), vLong, 4
End Sub

Function DeleteSubkeyTree(ByVal hKey As Long, ByVal Subkey As String) As Boolean
    Dim ret As Long, Index As Long, Name As String
    Dim hSubKey As Long

    ret = RegOpenKey(hKey, Subkey, hSubKey)
    If ret <> 0 Then
        DeleteSubkeyTree = False
        Exit Function
    End If
    ret = RegDeleteKey(hSubKey, "")
    If ret <> 0 Then
        While GetSubkeyByIndex(hSubKey, 0, Name) And _
              DeleteSubkeyTree(hSubKey, Name) ' 递回删除 Subkey 的 Subkey
        Wend
        ret = RegDeleteKey(hSubKey, "")
    End If
    DeleteSubkeyTree = (ret = 0)
End Function