10 API 搞定注册表精解示例

icecept · 发表于 2008-4-5 09:54:57

本帖最后由 icecept 于 2016-11-2 17:07 编辑

这次修改了在注册表中对于取单个值的问题，判断注册表中的值是什么值，并逐个返回，可以单独判断一个值或一个项不存在时的状态，精简并优化了一些代码。可以返回和设置二进制、16进制和dword值。
在窗体中：
'*************************************************************************
'**模块名：工程1 - Form1
'**说明：蓝凤凰设计商城－浴火凤凰－郭卫
'**创建人：蓝凤凰－魔灵
'**日期：2009-01-13 17:08:46
'**修改人：蓝凤凰－魔灵
'**日期：2009-01-13 17:08:46
'**描述：http://493405998.qzone.qq.com | http://blog.sina.com.cn/icecept | QQ:543375508
'**版本：V1.0.0
'*************************************************************************
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[/indent]

复制代码

icecept · 发表于 2008-4-5 09:56:40

本帖最后由 icecept 于 2016-11-2 17:16 编辑

'*************************************************************************
'**模块名：工程1 - 标准模块
'**说明：蓝凤凰设计商城－浴火凤凰－郭卫
'**创建人：蓝凤凰－魔灵
'**日期：2009-01-13 17:08:46
'**修改人：蓝凤凰－魔灵
'**日期：2009-01-13 17:08:46
'**描述：http://493405998.qzone.qq.com | http://blog.sina.com.cn/icecept | QQ:543375508
'**版本：V1.0.0
'*************************************************************************
在标准模块中：
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

复制代码

[ 本帖最后由 icecept 于 2009-1-13 17:01 编辑 ]

炉子 · 发表于 2008-4-5 09:57:16

恩。恩。恩。。

以前写过自己分析注册表HIVE格式的代码。。

icecept · 发表于 2008-4-27 11:32:11

本帖最后由 icecept 于 2016-11-2 17:10 编辑

消除用vb制作的系统右键菜单有下划线的方法，另赠送强大右键注册功能
2008-10-06 11:45

   在用vb制作系统右键菜单时，会出现在在字体下方有下划线的问题，超级解霸也有此毛病，我经过分析，终于让我发现了消除这一讨厌的下划线的方法，内幕全在注册表的设置上。只要用英文名做项，右键要显示的汉语名做默认值，这样就如你所愿了。请看以下程序。

'**************************************************************************
'**模块名：注册dll和ocx和tlb - Module1
'**说明：魔灵圣域版权所有2008 - 2009(C) by icecept(魔灵）
'**创建人：icecept(魔灵)
'**日期：2008-10-06 01:26:10
'**修改人：icecept(魔灵)
'**日期：
'**描述：icecept(魔灵)制作
'**版本：V1.0.0 http://blog.sina.com.cn/icecept
'*************************************************************************
Option Explicit
'注册表常数声明
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
'-注册表 API 声明...
'---------------------------------------------------------------
Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) 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 RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
'---------------------------------------------------------------
'获取系统路径的API函数
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Sub Main()
'句柄和返回值，返回值为0代表写入成功
Dim hKey As Long, retu As Long
'应用程序绝对路径
Dim RegXy As String, winsys As String
winsys = Space(250)
winsys = Left(winsys, GetSystemDirectory(winsys, Len(winsys)))
If Dir(CheckFilePath(App.Path) & "开闭光驱.exe") <> vbNullString Then
   FileCopy CheckFilePath(App.Path) & "开闭光驱.exe", winsys & "\开闭光驱.exe"
   ' 建立注册表项,设置开光驱右键菜单
   RegCreateKey HKEY_CLASSES_ROOT, "*\shell\opendoor", hKey
   retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "打开光驱", LenB(StrConv("打开光驱", vbFromUnicode)) + 1)
   RegCreateKey HKEY_CLASSES_ROOT, "*\shell\opendoor\command", hKey
   retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal winsys & "\开闭光驱.exe /opendoor", LenB(StrConv(winsys & "\开闭光驱.exe /opendoor", vbFromUnicode)) + 1)
   '设置闭光驱右键菜单
   RegCreateKey HKEY_CLASSES_ROOT, "*\shell\closedoor", hKey
   retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "关闭光驱", LenB(StrConv("关闭光驱", vbFromUnicode)) + 1)
   RegCreateKey HKEY_CLASSES_ROOT, "*\shell\closedoor\command", hKey
   retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal winsys & "\开闭光驱.exe /closedoor", LenB(StrConv(winsys & "\开闭光驱.exe /closedoor", vbFromUnicode)) + 1)
End If
'注： RegSetValueEx第二项为空时把值填入第一行的默认项
' 建立注册表项,设置注册dll
RegCreateKey HKEY_CLASSES_ROOT, ".dll", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "dllfile", LenB(StrConv("dllfile", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "dllfile\shell\regdll", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注册 dll 文件", LenB(StrConv("注册 dll 文件", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "dllfile\shell\regdll\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "regsvr32.exe " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
' 建立注册表项,设置反注册dll
RegCreateKey HKEY_CLASSES_ROOT, "dllfile\shell\unregdll", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注销 dll 文件", LenB(StrConv("注销 dll 文件", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "dllfile\shell\unregdll\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "regsvr32.exe /u " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe /u " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
' 建立注册表项,设置注册ocx
RegCreateKey HKEY_CLASSES_ROOT, ".ocx", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "ocxfile", LenB(StrConv("ocxfile", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "ocxfile\shell\regocx", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注册 ocx 文件", LenB(StrConv("注册 ocx 文件", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "ocxfile\shell\regocx\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "regsvr32.exe " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
' 建立注册表项,设置反注册ocx
RegCreateKey HKEY_CLASSES_ROOT, "ocxfile\shell\unregocx", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注销 ocx 文件", LenB(StrConv("注销 ocx 文件", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "ocxfile\shell\unregocx\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "regsvr32.exe /u " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe /u " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
' 建立注册表项,设置注册tlb
RegCreateKey HKEY_CLASSES_ROOT, ".tlb", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "tlbfile", LenB(StrConv("tlbfile", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "tlbfile\shell\regtlb", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注册类型库", LenB(StrConv("注册类型库", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "tlbfile\shell\regtlb\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "REGTLIB.EXE.exe " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
' 建立注册表项,设置反注册tlb
RegCreateKey HKEY_CLASSES_ROOT, "tlbfile\shell\unregtlb", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "注销类型库", LenB(StrConv("注销类型库", vbFromUnicode)) + 1)
RegCreateKey HKEY_CLASSES_ROOT, "tlbfile\shell\unregtlb\command", hKey
retu = RegSetValueEx(hKey, vbNullString, 0, REG_SZ, ByVal "REGTLIB.EXE /u " & Chr(34) & "%L" & Chr(34), LenB(StrConv("regsvr32.exe /u " & Chr(34) & "%L" & Chr(34), vbFromUnicode)) + 1)
RegCloseKey hKey
End
End Sub
Public Function CheckFilePath(FilePath As String) As String
'存、读档时对文件路径的检查
If Right(FilePath, 1) = "\" Then
   CheckFilePath = FilePath
Else
   CheckFilePath = FilePath & "\"
End If
End Function

删除建立的右键菜单

'**************************************************************************
'**模块名：删除右键菜单 - Module1
'**说明：魔灵圣域版权所有2008 - 2009(C) by icecept(魔灵）
'**创建人：icecept(魔灵)
'**日期：2008-10-10 00:14:59
'**修改人：icecept(魔灵)
'**日期：
'**描述：icecept(魔灵)制作
'**版本：V1.0.0 http://icecept.blog.sohu.com
'*************************************************************************

'=====================================
' 注册表的读写声明
'=====================================
'删除项目
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const REG_SZ = 1
Sub Main()
'以下删除右键的步骤是：先删除主项，在删除子项
'这里必须分步执行，如同删除文件夹一样，不能删除非空的文件夹，此处重要。
'也就是说在删除的项中可以有值，但不能有项
RegDeleteKey HKEY_CLASSES_ROOT, "dllfile\shell\regdll\command"
RegDeleteKey HKEY_CLASSES_ROOT, "dllfile\shell\regdll"
RegDeleteKey HKEY_CLASSES_ROOT, "dllfile\shell\unregdll\command"
RegDeleteKey HKEY_CLASSES_ROOT, "dllfile\shell\unregdll"
RegDeleteKey HKEY_CLASSES_ROOT, "ocxfile\shell\regocx\command"
RegDeleteKey HKEY_CLASSES_ROOT, "ocxfile\shell\regocx"
RegDeleteKey HKEY_CLASSES_ROOT, "ocxfile\shell\unregocx\command"
RegDeleteKey HKEY_CLASSES_ROOT, "ocxfile\shell\unregocx"
RegDeleteKey HKEY_CLASSES_ROOT, "tlbfile\shell\regtlb\command"
RegDeleteKey HKEY_CLASSES_ROOT, "tlbfile\shell\regtlb"
RegDeleteKey HKEY_CLASSES_ROOT, "tlbfile\shell\unregtlb\command"
RegDeleteKey HKEY_CLASSES_ROOT, "tlbfile\shell\unregtlb"
RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\opendoor\command"
RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\opendoor"
RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\closedoor\command"
RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\closedoor"
MsgBox "右键删除成功", vbOKOnly Or vbInformation
End Sub

附件: 注册dll和ocx和tlb.rar

[ 本帖最后由 icecept 于 2009-6-17 22:17 编辑 ]

icecept · 发表于 2008-4-27 11:34:37

本帖最后由 icecept 于 2016-11-2 17:09 编辑

'**************************************************************************
'**模块名：工程1 - Form1
'**说明：魔灵圣域 by icecept(郭卫）
'**创建人：icecept(魔灵)
'**日期：2009-02-09 11:30:19
'**修改人：icecept(魔灵)
'**版本：V1.0.0
'**E-mail ：icecept@163.com QQ：543375508
'**网址：http://blog.sina.com.cn/icecept
'*************************************************************************
'' 关闭打开的键
Private Declare Function RegCloseKey Lib "advapi32.dll" _
                     (ByVal hKey As Long) As Long
'建立键
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
                     (ByVal hKey As Long, _
                     ByVal lpSubKey As String, _
                     phkResult As Long) As Long
'写入启动值
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" ( _
                     ByVal hKey As Long, ByVal lpValueName As String, _
                     ByVal Reserved As Long, ByVal dwType As Long, _
                     ByVal lpData As String, ByVal cbData As Long) As Long
'删除加入的键值
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
                     ByVal hKey As Long, ByVal lpValueName As String) As Long
'打开注册表subkey的hkey
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
                     ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'得到注册表中的键值
Private 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
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_SZ = 1
Private Sub Command1_Click()
'把应用程序加入自运行
Dim hKey As Long
RegCreateKey HKEY_LOCAL_MACHINE, "SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN", hKey
RegSetValueEx hKey, App.EXEName, 0, REG_SZ, ByVal App.Path & "\" & App.EXEName & ".exe", LenB(StrConv(App.Path & "\" & App.EXEName & ".exe", vbFromUnicode)) + 1
RegCloseKey hKey
MsgBox "成功加入启动项", , "提示"
End Sub
'注：RegSetValeEx的第五个值可改为 ByVal RegXy,第六句可改为 lenB(RegXy)
'Dim RegXy as long:RegXy =app.path & "\记事薄.exe"
'regsetvalueex第二项为空时把值填入第一行的默认项,非空时，把值填入指定项目中的最后一行
Private Sub Command2_Click()
'把应用程序退出自运行
Dim hKey As Long, ret As Long '打开键的句柄
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN", hKey
ret = RegDeleteValue(hKey, App.EXEName)
If ret <> 0 Then
   MsgBox "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN\" & App.EXEName & "不存在"
   Exit Sub
End If
RegCloseKey hKey
MsgBox "成功删除启动项", vbOKOnly, "提示"
End Sub
Private Sub Command3_Click()
Dim hKey As Long, ret As Long '打开键的句柄
Dim Name As String * 255, lngTypeData As Long
Dim intname1 As Integer
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWARE\MICROSOFT\WINDOWS\CURRENTVERSION\RUN", hKey
RegQueryValueEx hKey, App.EXEName, 0&, lngTypeData, ByVal Name, Len(Name)
'返回command项App.EXEName
intname1 = InStr(Name, App.EXEName)
If intname1 <> 0 Then
   Label1.Caption = Left(Name, InStr(Name, Chr(0)) - 1)
Else
   MsgBox "没有值:" & App.EXEName, vbOKOnly Or vbInformation, "提示"
   Label1.Caption = vbNullString
End If
RegCloseKey hKey
End Sub
'-------------------------------------------------------------------------------------------------

'字符串以any的方式传递时,将转换为 ansi形式,,any 只能传址,于是,得到的是一个存ansi string的地址
'不是字符串的真正地址 , 是上一级地址, api函数是无法检测地址是否正确的, 他填充了这个地址, 但这个地址其实是栈的地址, 把栈给弄瘫痪了就乱套了
'
'以后遇到api传字符串的声明, 需要回传数据的用 byval xx as string 声明,不需要的大多数也要用 byval xx as string,特殊情况要用 byref

附件: 建立和删除自启动RegDeleteValue.rar

[ 本帖最后由 icecept 于 2009-2-16 17:54 编辑 ]

icecept · 发表于 2008-4-30 12:21:39

本帖最后由 icecept 于 2016-11-2 17:08 编辑

此程序功能是把电脑中的应用都锁住不让运行，只让运行杀毒软件、注册表、explorer和本程序。
友情提示：此程序具有一定的危险性，请新手不要擅自模仿。如果为此而造成损失，本
作者将不承担任何责任。
在窗体中：
'**************************************************************************
'**模块名：限制程序运行 - Form1
'**说明：魔灵圣域版权所有2008 - 2009(C)
'**创建人：郭卫(魔灵)
'**日期：2008-04-30 00:33:12
'**修改人：郭卫
'**日期：
'**描述：郭卫制作
'**版本：V1.0.0 http:/blog.sina.com.cn/icecept
'*************************************************************************
Option Explicit
Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_SZ = 1 ' -->字符串
Private Const REG_DWORD = 4 ' -->长整数
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private 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.
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private hKey As Long
Private Sub Command1_Click()
'建立禁止运行任何程序
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
RegSetValueEx hKey, "RestrictRun", 0, REG_DWORD, 1&, 4
RegCreateKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\RestrictRun", hKey
'建立充许运行的的程序，以下三个键值极为重要，它是为自己留的后门，否则你就重装系统吧
RegSetValueEx hKey, "Onlyme", 0, REG_SZ, ByVal "Onlyme.exe", LenB(StrConv("Onlyme.exe", vbFromUnicode)) + 1
RegSetValueEx hKey, "注册表", 0, REG_SZ, ByVal "regedit.exe", LenB(StrConv("regedit.exe", vbFromUnicode)) + 1
RegSetValueEx hKey, "Explorer", 0, REG_SZ, ByVal "Explorer.exe", LenB(StrConv("Explorer.exe", vbFromUnicode)) + 1
RegCloseKey hKey
RebootExplorer
End Sub
Private Sub Command2_Click()
'建立充许运行任何程序
RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
RegSetValueEx hKey, "RestrictRun", 0, REG_DWORD, 0&, 4
RegDeleteKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\RestrictRun"
RebootExplorer
End Sub

复制代码

附件: 只运行许可的Windows应用程序.rar

图片附件: QQ截图未命名.jpg

[ 本帖最后由 icecept 于 2009-1-13 17:08 编辑 ]

dazuo0459 · 发表于 2008-5-8 09:19:17

好东西，仔细研究下！

DreamonII · 发表于 2008-5-18 11:02:30

好贴!
收藏学习!

appleking · 发表于 2008-5-21 13:38:10

好东东以前可是打着灯笼都难找啊

lihaidomain · 发表于 2008-5-21 14:02:20

好贴! 收藏了，谢谢！

		自动登录	找回密码
密码			立即注册

VBGood网站全文搜索

[经验技巧] 10 API 搞定注册表精解示例

评分

本帖被以下淘专辑推荐:

接上面

评分

应用程序加入右键菜单和删除右键菜单最新修改

添加启动项和删除启动项

定电脑，只运行许可的Windows应用程序