如何取得與設定、刪除Registry內的值

如何取得與設定、刪除Registry內的值

至於什麼是Key, SubKey, ValueName等
名詞，請參考本人 VB5 Call WinAPI技巧


原始來源:王國榮

程式啟動時，會在 "HKEY_LOCAL_MACHINE\kj\Registry" Subkey 底下寫入：(此時
會呼叫 SetDefaultValue 及 SetValue 函數)

        資料類型        名稱            資料
        =========       ==============  ================================
                        (預設值)        kj Registry Master
        REG_SZ          StringData      這是字串
        REG_MULTI_SZ    MultiString     字串一(0) +字串二+Chr(0) +Chr(0)
        REG_DWORD       LongData        99999
        REG_BINARY      BinaryData      11 22 33 44 AA BB CC DD

接著當您按下「顯示所有 Value 時」(command1)時，程式會讀出來所有 Value 並且
顯示在ListBox 之中(此時會呼叫 GetDefaultValue、GetValueByIndex 函數)。

最後當程式結束時，則會刪除以上所有的 Value(此時會呼叫 GetValueByIndex 函數
及 RegDeleteValue API 函數)。

'請放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