原始来源:王国荣
程式启动时，会在 "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