www.pudn.com > netserver.zip > REGEDIT.BAS
Attribute VB_Name = "Regedit"
'VB提供了四个访问Windows注册表的函数，但是只能访问
'“HKEY_CURRENT_USER\Software\VB and VBA Program Settings”下,
'不能任意的访问，也不能存取除字符串以外类型的字段，幸好VB能通
'过于Windows API来访问注册表，于是笔者根据API函数编
'写这个访问注册表的模块，希望能对你有帮助。
'函数声明
Public Declare Function RegOpenKey Lib "advapi32.dll" _
Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
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 RegQueryValue Lib "advapi32.dll" _
Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey _
As String, ByVal lpValue As String, lpcbValue 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
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 Any, _
lpcbData As Long) As Long
'注意：原来的API浏览器中lpData原来的类型是Byte ，由于这个类型只支持
'Byte类型，所以改为Any类型才可正常读出数据
Public Declare Function RegDeleteValue Lib "advapi32.dll" _
Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _
lpValueName As String) As Long
Public 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
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, lpData As Any, ByVal cbData As Long) As Long
Public 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
Public Declare Function RegDeleteKey Lib "advapi32.dll" _
Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String) As Long
Public Declare Function ExpandEnvironmentStrings Lib "kernel32" _
Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, _
ByVal lpDst As String, ByVal nSize As Long) As Long
Public Enum OpTypeString
oString = 1 '字符串
oExpandSZ = 2 '展开式字符串
oLongData = 7 '多重字符串
End Enum
Public Enum OpTypeNumber
oLong = 4 '长整型
oBinary = 3 'Binary数据
oBigEndian = 5 'Big Endian长整数
End Enum
Public Enum OHKEY
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
End Enum
Public Function RegSaveStringValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As OpTypeString, hKeyValue As String) As Boolean
'写入字符串型数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, retk As Long, cbData As Long '声明变量
hKeyValue = hKeyValue + Chr(0)
RegSaveStringValue = False
cbData = LenB(StrConv(hKeyValue, vbFromUnicode)) '读取字符串的实际长度
ret = RegCreateKey(mhKey, lpSubKey, hKey) '如果人打开这个主键，没有则创建该主键
If ret = 0 Then
If RegSetValueEx(hKey, hKeyName, 0, hValueType, ByVal hKeyValue, cbData) = 0 Then
RegSaveStringValue = True '成功则返回真值
End If
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function
Public Function RegSaveNumberValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As OpTypeNumber, hKeyValue As Long) As Boolean
'写入数字型数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, retk As Long, cbData As Long
cbData = 4 'Len(CStr(hKeyValue))
RegSaveNumberValue = False
ret = RegCreateKey(mhKey, lpSubKey, hKey)
If ret = 0 Then
If RegSetValueEx(hKey, hKeyName, 0, hValueType, hKeyValue, cbData) = 0 Then
RegSaveNumberValue = True
End If
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function
Public Function RegReadValue(mhKey As OHKEY, lpSubKey As String, hKeyName As String, hValueType As Long, hKeyValue As String) As Boolean
'读取数据
'mhKey是指主键的名称，lpSubKey是指路径，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, lenData As Long
ret = RegOpenKey(mhKey, lpSubKey, hKey)
If ret = 0 Then
RegReadValue = True
'读取数据类型
ret = RegQueryValueEx(hKey, hKeyName, 0, hValueType, ByVal vbNullString, lenData)
Select Case hValueType
Case OpTypeString.oExpandSZ, OpTypeString.oLongData, OpTypeString.oString
'如果是字符型
Dim s As String, s2 As String
s = String(lenData, Chr(0))
RegQueryValueEx hKey, hKeyName, 0, hValueType, ByVal s, lenData
Select Case hValueType
Case OpTypeString.oString '如果是字符串
hKeyValue = Left(s, InStr(s, Chr(0)) - 1)
Case OpTypeString.oExpandSZ '如果是展开式字符串
s2 = String(Len(s) + 256, Chr(0))
ExpandEnvironmentStrings s, s2, Len(s2)
hKeyValue = Left(s2, InStr(s2, Chr(0)) - 1)
Case OpTypeString.oLongData '如果是多重字符串
hKeyValue = Left(s, Len(s) - 1)
End Select
Case OpTypeNumber.oBigEndian, OpTypeNumber.oLong
'如果是长整型
Dim l As Long
RegQueryValueEx hKey, hKeyName, 0, hValueType, l, lenData
hKeyValue = CStr(l)
Case OpTypeNumber.oBinary
'如果是二进制型
ReDim bArr(0 To lenData - 1) As Byte
RegQueryValueEx hKey, hKeyName, 0, hValueType, bArr(0), lenData
For i = 1 To lenData - 1
hKeyValue = hKeyValue + Hex(bArr(i))
Next i
End Select
Else
RegReadValue = False
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function
Public Function RegDeleteSubkey(hKey As OHKEY, SubKey As String)
'删除目录
'mhKey是指主键的名称，SubKey是指路径
Dim ret As Long, Index As Long, hName 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 '如果删除失败则认为是NT则用递归方法删除目录
Name = String(256, Chr(0))
While RegEnumKey(hSubkey, 0, hName, Len(hName)) = 0 And _
DeleteSubkeyTree(hSubkey, hName)
Wend
ret = RegDeleteKey(hSubkey, "")
End If
DeleteSubkeyTree = (ret = 0)
RegCloseKey hSubkey '删除打开的键值，释放内存
End Function
Public Function RegDeleteKeyName(mhKey As OHKEY, SubKey As String, hKeyName As String) As Boolean
'删除子键数据
'mhKey是指主键的名称，SubKey是指路径，hKeyName是指键名
Dim hKey As Long, ret As Long
ret = RegOpenKey(mhKey, SubKey, hKey)
RegDeleteKeyName = False
If ret = 0 Then
If RegDeleteValue(hKey, hKeyName) = 0 Then RegDeleteKeyName = True
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function
Public Function RegCountSubKey(mhKey As OHKEY, SubKey As String) As Long
'统计所有子键数目
'mhKey是指主键的名称，SubKey是指路径
Dim hKey As Long, ret As Long, idx As Long, lenName As Long, lpValeName As String, TypeData As Long, lenData As Long
idx = 0
ret = RegOpenKey(mhKey, SubKey, hKey)
If ret = 0 Then
While RegEnumValue(hKey, idx, lpValeName, lenName, ByVal 0, TypeData, ByVal vbNullString, lenData) = 0
idx = idx + 1
Wend
End If
RegCountSubKey = idx
RegCloseKey hKey '删除打开的键值，释放内存
End Function
Public Function RegEnumSubKey(mhKey As OHKEY, SubKey As String, hKeyIndex As Long, hKeyName As String, hKeyType As Long, hKeyValue As String) As Boolean
'读取指定的子键键值
'mhKey是指主键的名称，SubKey是指路径，hKeyIndex是指定要返回第几个键名，hKeyName是指键名，hValueType是指键值的数据类型，hKeyValue是指数据
Dim hKey As Long, ret As Long, lenName As Long, lpValeName As String, TypeData As Long, lenData As Long
Dim s As String
s = String(lenData, Chr(0))
lenName = 256
lpValeName = String(256, Chr(0))
RegEnumSubKey = False
ret = RegOpenKey(mhKey, SubKey, hKey)
If ret = 0 Then
If RegEnumValue(hKey, ByVal hKeyIndex, lpValeName, lenName, ByVal 0, TypeData, ByVal vbNullString, lenData) = 0 Then
hKeyName = Left(lpValeName, InStr(lpValeName, Chr(0)) - 1) ' Left(s, InStr(s, Chr(0)) - 1)
If RegReadValue(mhKey, SubKey, hKeyName, hKeyType, hKeyValue) Then
RegEnumSubKey = True
End If
End If
End If
RegCloseKey hKey '删除打开的键值，释放内存
End Function