10个api函数搞定注册表

 

       修改了在注册表中对于取单个值的问题，判断注册表中的值是什么值，并逐个返回，可以单独判断一个值或一个项不存在时的状态，精简并优化了一些代码。可以返回和设置二进制、16进制和dword值。
在窗体中：

*************************************************************************
'**模 块 名：Form1
**说 明：永远的魔灵 by icecept(郭卫）
'**创 建 人：icecept(魔灵)
'**日 期：2009-11-15 20:27:03
'**修 改 人：icecept(魔灵)
'**版 本：V1.0.0
'**E-mail   ：icecept@163.com QQ：543375508
'**网 址：http://hi.baidu.com/icecepthttp://icecept.jimdo.com
'*************************************************************************
Option Explicit
Dim ret As Long, ret1 As Long
Dim hKey As Long
Private Sub Command1_Click()
Dim Name As String * 255
Dim intname1 As Integer   '文件名所在的位置
Dim lngTypeData As Long   '返回注册表值的数据类型
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command", hKey) Then
       '返回command项默认值
       RegQueryValueEx hKey, vbNullString, 0&, lngTypeData, ByVal Name, Len(Name)
       intname1 = InStr(Name, "我的预设值")
       If intname1 <> 0 Then
         Label1.Caption = "预设值=" & Left(Name, InStr(Name, Chr(0)) - 1) & " 数据类型=" & RegDataType(lngTypeData)
       Else
         Label1.Caption = vbNullString
         MsgBox "注册表项存在,但没有预设值", vbOKOnly Or vbInformation, "提示"
       End If
Else
       MsgBox "注册表项不存在，所以没有预设值", vbOKOnly Or vbInformation, "提示"
End If
End Sub
Private Sub Command2_Click()
ret = RegCreateKey(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command", hKey)
'RegSetValueEx 第二个参数为空时，值写入默认项,否则写入相应的键值
'当值是字符串时第五个和六个参数的ByVal 必须带，否则会出现乱码。数值不用带ByVal
'否则也会出错
'写入预设值
RegSetValueEx hKey, vbNullString, 0, REG_SZ, ByVal "我的预设值", LenB(StrConv("我的预设值", vbFromUnicode)) + 1
'写入二进制值
RegSetValueEx hKey, "我的值", 0, REG_BINARY, 1234&, 4
'写入16进制值
RegSetValueEx hKey, "测试", 0, REG_DWORD, 1234&, 4
'写入字符串值
RegSetValueEx hKey, "我的值1", 0, REG_SZ, ByVal "这里只能放字符串", LenB(StrConv("这里只能放字符串", vbFromUnicode)) + 1
RegCloseKey hKey
End Sub
Private Sub Command3_Click()
Dim Name As String * 255, Name1 As Long
Dim lngTypeData As Long   '返回注册表值的数据类型
Dim intname1 As Integer
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command", hKey) Then
       '返回command项预设值
       RegQueryValueEx hKey, vbNullString, 0&, lngTypeData, ByVal Name, Len(Name)
       intname1 = InStr(Name, "我的预设值")
       If intname1 <> 0 Then
         '如果RegDeleteValue的第二个值为空，则删除预设值
         RegDeleteValue hKey, ByVal vbNullString
       Else
         Label1.Caption = vbNullString
         MsgBox "注册表项存在,但没有预设值", vbOKOnly Or vbInformation, "提示"
       End If
       '返回command项我的值
       RegQueryValueEx hKey, "我的值", 0&, lngTypeData, Name1, Len(Name1)
       intname1 = InStr(Name1, "1234")
       If intname1 <> 0 Then
         RegDeleteValue hKey, ByVal "我的值"
       Else
         Label1.Caption = vbNullString
         MsgBox "注册表项存在,但没有我的值", vbOKOnly Or vbInformation, "提示"
       End If
       '返回command项测试
       RegQueryValueEx hKey, "测试", 0&, lngTypeData, Name1, Len(Name1)
       intname1 = InStr(Name1, "1234")
       If intname1 <> 0 Then
         RegDeleteValue hKey, ByVal "测试"
       Else
         Label1.Caption = vbNullString
         MsgBox "注册表项存在,但没有测试", vbOKOnly Or vbInformation, "提示"
       End If
       '返回command项我的值1
       RegQueryValueEx hKey, "我的值1", 0&, lngTypeData, ByVal Name, Len(Name)
       intname1 = InStr(Name, "这里只能放字符串")
       If intname1 <> 0 Then
         RegDeleteValue hKey, ByVal "我的值1"
       Else
         Label1.Caption = vbNullString
         MsgBox "注册表项存在,但没有我的值1", vbOKOnly Or vbInformation, "提示"
       End If
Else
       MsgBox "注册表项不存在,所以没有值。", vbOKOnly Or vbInformation, "提示"
End If
RegCloseKey hKey
End Sub
Private Sub Command4_Click()
'这里必须分步执行，如同删除文件夹一样，不能删除非空的文件夹，此处重要。
'也就是说在删除的项中可以有值，但不能有项
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command") Then
       RegDeleteKey HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command"
       RegDeleteKey HKEY_CLASSES_ROOT, "*/shell/用记事本打开"
       MsgBox "注册表项已经删除", vbOKOnly Or vbInformation, "提示"
Else
       MsgBox "注册表项不存在", vbOKOnly Or vbInformation, "提示"
End If
End Sub
Private Sub Command5_Click()
Label1.Caption = vbNullString
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command") Then
       If GetRegAllValue(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command") = vbNullString Then
         MsgBox "要读取的注册表项存在，但是没有值", vbOKOnly Or vbInformation, "提示"
       Else
         Label1.Caption = GetRegAllValue(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command")
       End If
Else
       MsgBox "要读取的注册表项不存在，所以没有值", vbOKOnly Or vbInformation, "提示"
End If
End Sub
Private Sub Command6_Click()
Label1.Caption = vbNullString
Dim hKey As Long, ret As Long, Name As String * 255, idx As Long
idx = 0
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开", hKey) Then
       Do While RegEnumKey(hKey, idx, Name, 256) = 0&
         Label1.Caption = Label1.Caption & vbCrLf & Name
         idx = idx + 1
       Loop
Else
       MsgBox "要读取的注册表项不存在", vbOKOnly Or vbInformation, "提示"
End If
RegCloseKey hKey
End Sub
Private Sub Command7_Click()
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command") Then
       Label1.Caption = "HKEY_CLASSES_ROOT/*/shell/用记事本打开/command项存在"
Else
       Label1.Caption = "HKEY_CLASSES_ROOT/*/shell/用记事本打开/command项不存在"
End If
End Sub
Private Sub Command8_Click()
Dim Name As String * 255, Name1 As Long, Name2 As Long
Dim lngTypeData As Long   '返回注册表值的数据类型
Dim intname1 As Integer
If IsSubKeyName(HKEY_CLASSES_ROOT, "*/shell/用记事本打开/command", hKey) Then
       '返回command项测试值
       RegQueryValueEx hKey, "测试", 0&, lngTypeData, Name1, Len(Name1)
       intname1 = InStr(Name1, 1234)
       If intname1 <> 0 Then
         Label1.Caption = "测试=" & Name1 & " 数据类型=" & RegDataType(lngTypeData)
       Else
         MsgBox "要读取的注册表项存在，但是没有值", vbOKOnly Or vbInformation, "提示"
       End If
       '返回command项我的值
       RegQueryValueEx hKey, "我的值", 0&, lngTypeData, Name2, Len(Name2)
       intname1 = InStr(Name2, 1234)
       If intname1 <> 0 Then
         Label1.Caption = Label1.Caption & vbCrLf & vbCrLf & "我的值=" & Name2 & " 数据类型=" & RegDataType(lngTypeData)
       Else
         MsgBox "要读取的注册表项存在，但是没有值", vbOKOnly Or vbInformation, "提示"
       End If
       '返回command项我的值1
       RegQueryValueEx hKey, "我的值1", 0&, lngTypeData, ByVal Name, Len(Name)
       intname1 = InStr(Name, "这里只能放字符串")
       If intname1 <> 0 Then
         Label1.Caption = Label1.Caption & vbCrLf & vbCrLf & "我的值1=" & Left(Name, InStr(Name, Chr(0)) - 1) & " 数据类型=" & RegDataType(lngTypeData)
       Else
         MsgBox "要读取的注册表项存在，但是没有值", vbOKOnly Or vbInformation, "提示"
       End If
Else
       MsgBox "要读取的注册表项不存在，所以没有值", vbOKOnly Or vbInformation, "提示"
End If
End Sub
Private Function RegDataType(typeData As Long) As String
Select Case typeData
       Case REG_BINARY
       RegDataType = "2进制"
       Case REG_SZ
       RegDataType = "字符串"
       Case REG_EXPAND_SZ
       RegDataType = "字符串"
       Case REG_MULTI_SZ
       RegDataType = "字符串"
       Case REG_DWORD
       RegDataType = "16进制"
End Select
End Function

在标准模块中：
Option Explicit
'注意以下的函数声明须在一行内写完
''''//注册表基本键值列表
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
''''键值类型常用取值
Public Const REG_NONE = 0
Public Const REG_SZ = 1                ' -->字符串
Public Const REG_EXPAND_SZ = 2          ' -->可展开式字符串
Public Const REG_BINARY = 3             ' -->Binary数据
Public Const REG_DWORD = 4             ' -->长整数
Public Const REG_DWORD_BIG_ENDIAN = 5     ' -->BIG_ENDIAN长整数
Public Const REG_MULTI_SZ = 7          '-->多重字符串
'RegCreateKey 函数
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'在指定的项下创建一个新项，如果指定的项已存在，则打开这个项
'hKey 当前打开项的句柄?
'lpSubKey 注册表新子项的名称
'phkresult 指定一个变量，装载新子项的句柄
'它的参数用法与RegOpenKey一样。所不同的是RegOpenKey只能打开已经有的SubKey,
'而RegCreateKey则可以建立SubKey,比较特别的是，如果调用RegCreateKey所建立
'的SubKey是一个已经存在的SubKey , 则它的功能和RegOpenKey相同?由于RegCreateKey
'的这种特性，有的程序员干脆不用RegOpenKey，而用RegCreateKey来统一代替RegOpenKey。
'RegOpenKey --取得SubKey的Hkey
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'hKey 当前打开项的句柄   函数
'lpSubKey 要打开项的名称
'phkresult   指定一个变量，装载新子项的句柄
'phkResult:若RegOpenKey执行成功，则这一参数返回Subkey的hKey.
'RegCloseKey
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'hKey   当前打开项的句柄   函数
'当我们不再存取Registry时，将打开或建立的SubKey关闭是一个比较好的习惯，就正如我们在使用C语言的文件打开函数后必须要关闭一样。
'返回值: =0,表示成功；≠0,表示失败。[注意这一点与别的API函数不太一样]
'RegSetValueEx --设置某Key特定名称的值(Value)
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       ' Note that if you declare the lpData parameter as String, you must pass it By Value.
'在一个注册表项下设置一个指定值的数据和类型
'hKey 当前打开项的句柄
'lpValueName 要设置值的名称
'Reserved 未用，设为0
'dwType 要设置值的数据类型
'lpData 要设置值的数据
'cbData 缓冲区的长度
'
'返回值: =0,表示成功；≠0,表示失败。
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
'hKey: Key Handle
'lpValueName: Value名称，如果想删除预设值的话，传入""[空字符串]即可。
'返回值: =0,表示成功；≠0,表示失败。
'RegDeleteKey --删除Key或者SubKey
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'hKey: Key Handle
'lpSubKey:SubKey名称或者路径，若传入""[空字符串],表示删除Key本身。
'返回值: =0,表示成功；≠0,表示失败。
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
'RegEnumKey --列出某Key的所有SubKey
'
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
'hKey: Key Handle
'dwIndex: 欲读取的SubKey的顺序
'lpName: 返回所读取的SubKey的名称
'cbName: 传入lpName的字符串长度?
'返回值: =0,表示成功；≠0,表示失败。
'RegQueryValueEx --读取某Key的特定名称的值(Value)
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
'hkey: Key Handle
'lpValueName: Value Name
'lpReserved:保留参数，调用时设置为0即可
'lpType: 返回读取的数据类型
'lpData: 返回读取的数据,如果是REG_SZ类型，前面就必须加ByVal,否则程序崩溃，其它类型不能加ByVal
'lpcbData:传入lpData数据的长度，若成功读取数据，则返回所读取的数据的长度。
'返回值: =0,表示成功；≠0,表示失败。
'说明:
'1、 这一函数除了可读取指定名称的值之外，也可以读取default value。如果要读取default value,只需要将
'参数lpValueName设置为""[空字符串]即可。
'2 ?lpType 的可能取值
'Enum ValueType
'REG_NONE = 0
'REG_SZ = 1 -->字符串
'REG_EXPAND_SZ = 2 -->可展开式字符串
'REG_BINARY = 3 -->Binary数据
'REG_DWORD = 4 -->长整数
'REG_DWORD_BIG_ENDIAN = 5 -->BIG_ENDIAN长整数
'REG_MULTI_SZ = 7 -->多重字符串
'End Enum
Sub MultiStringToStringArray(S As String, S2() As String)
'S为我们读取出来的多重字符串
'S2为转换后的字符串数组
Dim count As Integer, pos As Integer, pos2 As Integer, idx As Integer
pos = InStr(S, Chr(0))
While pos > 0
       count = count + 1
       pos = InStr(pos + 1, S, Chr(0))
Wend
'取得多重字符串中的字符串个数
count = count - 1
ReDim S2(0 To count - 1)
pos = 1
For idx = 0 To count - 1
       pos2 = InStr(pos, S, Chr(0))
       S2(idx) = Mid(S, pos, pos2 - pos)
       pos = pos2 + 1
Next
End Sub
'列举所有注册表项的值
Public Function GetRegAllValue(RootKey As Long, SubKeyName As String) As String
Dim ret As Long, lenData As Long, typeData As Long, hKey As Long
Dim Name As String
Dim lenName As Long
Dim idx As Integer, j As Integer
Dim bName(256) As Byte
ret = RegOpenKey(RootKey, SubKeyName, hKey)
If ret <> 0 Then Exit Function
ret = 0
idx = 0
While ret = 0
       lenName = 256
       ret = RegEnumValue(hKey, idx, bName(0), lenName, ByVal 0, typeData, ByVal vbNullString, lenData)
       If ret <> 0 Then
         RegCloseKey hKey
         Exit Function
       End If
       '上面的RegEnumValue调用得到了第一个Name的长度lenName,不含chr(0)
       Name = String(lenName + 1, Chr(0))
       lenName = Len(Name)
       Select Case typeData
         Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
         Dim S As String
         S = String(lenData, Chr(0))
         RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, ByVal S, lenData
         If typeData = REG_SZ Then
            S = Left(S, InStr(S, Chr(0)) - 1)
            GetRegAllValue = GetRegAllValue & IIf(lenName = 0, "(预设值)", Left(Name, InStr(Name, Chr(0)) - 1)) & "=" & S & vbCrLf
         ElseIf typeData = REG_EXPAND_SZ Then
            Dim S2 As String
            S2 = String(Len(S) + 256, Chr(0))
            ExpandEnvironmentStrings S, S2, Len(S2)
            S = Left(S2, InStr(S2, Chr(0)) - 1)
            GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = " & S & vbCrLf
         ElseIf typeData = REG_MULTI_SZ Then
            Dim SArr() As String
            MultiStringToStringArray S, SArr
            For j = 0 To UBound(SArr)
                   GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & "(" & j & ") = " & SArr(j) & vbCrLf
            Next
         End If
         Case REG_DWORD, REG_DWORD_BIG_ENDIAN
         Dim L As Long
         RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, L, lenData
         GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = " & L & vbCrLf
         Case REG_BINARY
         ReDim bArr(0 To lenData - 1) As Byte
         RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, bArr(0), lenData
         GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = "
         For j = 0 To UBound(bArr)
            GetRegAllValue = GetRegAllValue & Hex(bArr(j)) & " "
         Next
         GetRegAllValue = GetRegAllValue & vbCrLf
       End Select
       idx = idx + 1
Wend
RegCloseKey hKey
End Function
'判断注册项是否存在
Public Function IsSubKeyName(RootKey As Long, SubKeyName As String, Optional hKey As Long) As Boolean
If RegOpenKey(RootKey, SubKeyName, hKey) = 0& Then
       IsSubKeyName = True
Else
       IsSubKeyName = False
End If
End Function
附件: 注册表语句应用示例终级完美版.rar