VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 31222|回复: 57

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

[复制链接]
 楼主| 发表于 2008-4-5 09:54:57 | 显示全部楼层 |阅读模式
本帖最后由 icecept 于 2016-11-2 17:07 编辑


  1. 这次修改了在注册表中对于取单个值的问题,判断注册表中的值是什么值,并逐个返回,可以单独判断一个值或一个项不存在时的状态,精简并优化了一些代码。可以返回和设置二进制、16进制和dword值。
  2. 在窗体中:
  3. '*************************************************************************
  4. '**模 块 名:工程1 - Form1
  5. '**说    明:蓝凤凰设计商城-浴火凤凰-郭卫
  6. '**创 建 人:蓝凤凰-魔灵
  7. '**日    期:2009-01-13 17:08:46
  8. '**修 改 人:蓝凤凰-魔灵
  9. '**日    期:2009-01-13 17:08:46
  10. '**描    述:http://493405998.qzone.qq.com |  http://blog.sina.com.cn/icecept |  QQ:543375508
  11. '**版    本:V1.0.0
  12. '*************************************************************************
  13. Option Explicit
  14. Dim ret As Long, ret1 As Long
  15. Dim hKey As Long
  16. Private Sub Command1_Click()
  17.     Dim Name As String * 255
  18.     Dim intname1 As Integer  '文件名所在的位置
  19.     Dim lngTypeData As Long  '返回注册表值的数据类型
  20.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command", hKey) Then
  21.         '返回command项默认值
  22.         RegQueryValueEx hKey, vbNullString, 0&, lngTypeData, ByVal Name, Len(Name)
  23.         intname1 = InStr(Name, "我的预设值")
  24.         If intname1 <> 0 Then
  25.             Label1.Caption = "预设值=" & Left(Name, InStr(Name, Chr(0)) - 1) & " 数据类型=" & RegDataType(lngTypeData)
  26.         Else
  27.             Label1.Caption = vbNullString
  28.             MsgBox "注册表项存在,但没有预设值", vbOKOnly Or vbInformation, "提示"
  29.         End If
  30.     Else
  31.         MsgBox "注册表项不存在,所以没有预设值", vbOKOnly Or vbInformation, "提示"
  32.     End If
  33. End Sub
  34. Private Sub Command2_Click()
  35.     ret = RegCreateKey(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command", hKey)
  36.     'RegSetValueEx 第二个参数为空时,值写入默认项,否则写入相应的键值
  37.     '当值是字符串时第五个和六个参数的ByVal 必须带,否则会出现乱码。数值不用带ByVal
  38.     '否则也会出错
  39.     '写入预设值
  40.     RegSetValueEx hKey, vbNullString, 0, REG_SZ, ByVal "我的预设值", LenB(StrConv("我的预设值", vbFromUnicode)) + 1
  41.     '写入二进制值
  42.     RegSetValueEx hKey, "我的值", 0, REG_BINARY, 1234&, 4
  43.     '写入16进制值
  44.     RegSetValueEx hKey, "测试", 0, REG_DWORD, 1234&, 4
  45.     '写入字符串值
  46.     RegSetValueEx hKey, "我的值1", 0, REG_SZ, ByVal "这里只能放字符串", LenB(StrConv("这里只能放字符串", vbFromUnicode)) + 1
  47.     RegCloseKey hKey
  48. End Sub
  49. Private Sub Command3_Click()
  50.     Dim Name As String * 255, Name1 As Long
  51.     Dim lngTypeData As Long  '返回注册表值的数据类型
  52.     Dim intname1 As Integer
  53.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command", hKey) Then
  54.         '返回command项预设值
  55.         RegQueryValueEx hKey, vbNullString, 0&, lngTypeData, ByVal Name, Len(Name)
  56.         intname1 = InStr(Name, "我的预设值")
  57.         If intname1 <> 0 Then
  58.             '如果RegDeleteValue的第二个值为空,则删除预设值
  59.             RegDeleteValue hKey, ByVal vbNullString
  60.         Else
  61.             Label1.Caption = vbNullString
  62.             MsgBox "注册表项存在,但没有预设值", vbOKOnly Or vbInformation, "提示"
  63.         End If
  64.         '返回command项我的值
  65.         RegQueryValueEx hKey, "我的值", 0&, lngTypeData, Name1, Len(Name1)
  66.         intname1 = InStr(Name1, "1234")
  67.         If intname1 <> 0 Then
  68.             RegDeleteValue hKey, ByVal "我的值"
  69.         Else
  70.             Label1.Caption = vbNullString
  71.             MsgBox "注册表项存在,但没有我的值", vbOKOnly Or vbInformation, "提示"
  72.         End If
  73.         '返回command项测试
  74.         RegQueryValueEx hKey, "测试", 0&, lngTypeData, Name1, Len(Name1)
  75.         intname1 = InStr(Name1, "1234")
  76.         If intname1 <> 0 Then
  77.             RegDeleteValue hKey, ByVal "测试"
  78.         Else
  79.             Label1.Caption = vbNullString
  80.             MsgBox "注册表项存在,但没有测试", vbOKOnly Or vbInformation, "提示"
  81.         End If
  82.         '返回command项我的值1
  83.         RegQueryValueEx hKey, "我的值1", 0&, lngTypeData, ByVal Name, Len(Name)
  84.         intname1 = InStr(Name, "这里只能放字符串")
  85.         If intname1 <> 0 Then
  86.             RegDeleteValue hKey, ByVal "我的值1"
  87.         Else
  88.             Label1.Caption = vbNullString
  89.             MsgBox "注册表项存在,但没有我的值1", vbOKOnly Or vbInformation, "提示"
  90.         End If
  91.     Else
  92.         MsgBox "注册表项不存在,所以没有值。", vbOKOnly Or vbInformation, "提示"
  93.     End If
  94.     RegCloseKey hKey
  95. End Sub
  96. Private Sub Command4_Click()
  97.     '这里必须分步执行,如同删除文件夹一样,不能删除非空的文件夹,此处重要。
  98.     '也就是说在删除的项中可以有值,但不能有项
  99.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command") Then
  100.         RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command"
  101.         RegDeleteKey HKEY_CLASSES_ROOT, "*\shell\用记事本打开"
  102.         MsgBox "注册表项已经删除", vbOKOnly Or vbInformation, "提示"
  103.     Else
  104.         MsgBox "注册表项不存在", vbOKOnly Or vbInformation, "提示"
  105.     End If
  106. End Sub
  107. Private Sub Command5_Click()
  108.     Label1.Caption = vbNullString
  109.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command") Then
  110.         If GetRegAllValue(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command") = vbNullString Then
  111.             MsgBox "要读取的注册表项存在,但是没有值", vbOKOnly Or vbInformation, "提示"
  112.         Else
  113.             Label1.Caption = GetRegAllValue(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command")
  114.         End If
  115.     Else
  116.         MsgBox "要读取的注册表项不存在,所以没有值", vbOKOnly Or vbInformation, "提示"
  117.     End If
  118. End Sub
  119. Private Sub Command6_Click()
  120.     Label1.Caption = vbNullString
  121.     Dim hKey As Long, ret As Long, Name As String * 255, idx As Long
  122.     idx = 0
  123.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开", hKey) Then
  124.         Do While RegEnumKey(hKey, idx, Name, 256) = 0&
  125.             Label1.Caption = Label1.Caption & vbCrLf & Name
  126.             idx = idx + 1
  127.         Loop
  128.     Else
  129.         MsgBox "要读取的注册表项不存在", vbOKOnly Or vbInformation, "提示"
  130.     End If
  131.     RegCloseKey hKey
  132. End Sub
  133. Private Sub Command7_Click()
  134.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command") Then
  135.         Label1.Caption = "HKEY_CLASSES_ROOT\*\shell\用记事本打开\command项存在"
  136.     Else
  137.         Label1.Caption = "HKEY_CLASSES_ROOT\*\shell\用记事本打开\command项不存在"
  138.     End If
  139. End Sub
  140. Private Sub Command8_Click()
  141.     Dim Name As String * 255, Name1 As Long, Name2 As Long
  142.     Dim lngTypeData As Long  '返回注册表值的数据类型
  143.     Dim intname1 As Integer
  144.     If IsSubKeyName(HKEY_CLASSES_ROOT, "*\shell\用记事本打开\command", hKey) Then
  145.         '返回command项测试值
  146.         RegQueryValueEx hKey, "测试", 0&, lngTypeData, Name1, Len(Name1)
  147.         intname1 = InStr(Name1, 1234)
  148.         If intname1 <> 0 Then
  149.             Label1.Caption = "测试=" & Name1 & " 数据类型=" & RegDataType(lngTypeData)
  150.         Else
  151.             MsgBox "要读取的注册表项存在,但是没有值", vbOKOnly Or vbInformation, "提示"
  152.         End If
  153.         '返回command项我的值
  154.         RegQueryValueEx hKey, "我的值", 0&, lngTypeData, Name2, Len(Name2)
  155.         intname1 = InStr(Name2, 1234)
  156.         If intname1 <> 0 Then
  157.             Label1.Caption = Label1.Caption & vbCrLf & vbCrLf & "我的值=" & Name2 & " 数据类型=" & RegDataType(lngTypeData)
  158.         Else
  159.             MsgBox "要读取的注册表项存在,但是没有值", vbOKOnly Or vbInformation, "提示"
  160.         End If
  161.         '返回command项我的值1
  162.         RegQueryValueEx hKey, "我的值1", 0&, lngTypeData, ByVal Name, Len(Name)
  163.         intname1 = InStr(Name, "这里只能放字符串")
  164.         If intname1 <> 0 Then
  165.             Label1.Caption = Label1.Caption & vbCrLf & vbCrLf & "我的值1=" & Left(Name, InStr(Name, Chr(0)) - 1) & " 数据类型=" & RegDataType(lngTypeData)
  166.         Else
  167.             MsgBox "要读取的注册表项存在,但是没有值", vbOKOnly Or vbInformation, "提示"
  168.         End If
  169.     Else
  170.         MsgBox "要读取的注册表项不存在,所以没有值", vbOKOnly Or vbInformation, "提示"
  171.     End If
  172. End Sub
  173. Private Function RegDataType(typeData As Long) As String
  174.     Select Case typeData
  175.         Case REG_BINARY
  176.         RegDataType = "2进制"
  177.         Case REG_SZ
  178.         RegDataType = "字符串"
  179.         Case REG_EXPAND_SZ
  180.         RegDataType = "字符串"
  181.         Case REG_MULTI_SZ
  182.         RegDataType = "字符串"
  183.         Case REG_DWORD
  184.         RegDataType = "16进制"
  185.     End Select
  186. End Function[/indent]
复制代码

评分

参与人数 3威望 +12 人气 +2 收起 理由
红色狂想 + 1 + 1 精品文章
taotaolang + 1 + 1 很好
DreamonII + 10 实用,精品!

查看全部评分

本帖被以下淘专辑推荐:

 楼主| 发表于 2008-4-5 09:56:40 | 显示全部楼层

接上面

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

  1. '*************************************************************************
  2. '**模 块 名:工程1 - 标准模块
  3. '**说    明:蓝凤凰设计商城-浴火凤凰-郭卫
  4. '**创 建 人:蓝凤凰-魔灵
  5. '**日    期:2009-01-13 17:08:46
  6. '**修 改 人:蓝凤凰-魔灵
  7. '**日    期:2009-01-13 17:08:46
  8. '**描    述:http://493405998.qzone.qq.com |  http://blog.sina.com.cn/icecept |  QQ:543375508
  9. '**版    本:V1.0.0
  10. '*************************************************************************
  11. 在标准模块中:
  12. Option Explicit
  13. '注意以下的函数声明须在一行内写完
  14. ''''//注册表基本键值列表
  15. Public Const HKEY_CLASSES_ROOT = &H80000000
  16. Public Const HKEY_CURRENT_USER = &H80000001
  17. Public Const HKEY_LOCAL_MACHINE = &H80000002
  18. Public Const HKEY_USERS = &H80000003
  19. Public Const HKEY_CURRENT_CONFIG = &H80000005
  20. ''''键值类型常用取值
  21. Public Const REG_NONE = 0
  22. Public Const REG_SZ = 1                   '    -->字符串
  23. Public Const REG_EXPAND_SZ = 2            ' -->可展开式字符串
  24. Public Const REG_BINARY = 3               ' -->Binary数据
  25. Public Const REG_DWORD = 4                ' -->长整数
  26. Public Const REG_DWORD_BIG_ENDIAN = 5     ' -->BIG_ENDIAN长整数
  27. Public Const REG_MULTI_SZ = 7             '-->多重字符串
  28. 'RegCreateKey 函数
  29. Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  30. '在指定的项下创建一个新项,如果指定的项已存在,则打开这个项
  31. 'hKey 当前打开项的句柄?
  32. 'lpSubKey 注册表新子项的名称
  33. 'phkresult   指定一个变量,装载新子项的句柄
  34. '它的参数用法与RegOpenKey一样。所不同的是RegOpenKey只能打开已经有的SubKey,
  35. '而RegCreateKey则可以建立SubKey,比较特别的是,如果调用RegCreateKey所建立
  36. '的SubKey是一个已经存在的SubKey , 则它的功能和RegOpenKey相同?由于RegCreateKey
  37. '的这种特性,有的程序员干脆不用RegOpenKey,而用RegCreateKey来统一代替RegOpenKey。
  38. 'RegOpenKey --取得SubKey的Hkey
  39. Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  40. 'hKey 当前打开项的句柄  函数
  41. 'lpSubKey 要打开项的名称
  42. 'phkresult  指定一个变量,装载新子项的句柄
  43. 'phkResult:若RegOpenKey执行成功,则这一参数返回Subkey的hKey.
  44. 'RegCloseKey
  45. Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  46. 'hKey  当前打开项的句柄  函数
  47. '当我们不再存取Registry时,将打开或建立的SubKey关闭是一个比较好的习惯,就正如我们在使用C语言的文件打开函数后必须要关闭一样。
  48. '返回值: =0,表示成功;≠0,表示失败。[注意这一点与别的API函数不太一样]
  49. 'RegSetValueEx --设置某Key特定名称的值(Value)
  50. 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.
  51. '在一个注册表项下设置一个指定值的数据和类型
  52. 'hKey 当前打开项的句柄
  53. 'lpValueName 要设置值的名称
  54. 'Reserved 未用,设为0
  55. 'dwType 要设置值的数据类型
  56. 'lpData 要设置值的数据
  57. 'cbData 缓冲区的长度
  58. '
  59. '返回值: =0,表示成功;≠0,表示失败。
  60. Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
  61. 'hKey: Key Handle
  62. 'lpValueName: Value名称,如果想删除预设值的话,传入""[空字符串]即可。
  63. '返回值: =0,表示成功;≠0,表示失败。
  64. 'RegDeleteKey --删除Key或者SubKey
  65. Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  66. 'hKey: Key Handle
  67. 'lpSubKey:SubKey名称或者路径,若传入""[空字符串],表示删除Key本身。
  68. '返回值: =0,表示成功;≠0,表示失败。
  69. 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
  70. Public Declare Function ExpandEnvironmentStrings Lib "kernel32" Alias "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, ByVal nSize As Long) As Long
  71. 'RegEnumKey --列出某Key的所有SubKey
  72. '
  73. 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
  74. 'hKey: Key Handle
  75. 'dwIndex: 欲读取的SubKey的顺序
  76. 'lpName: 返回所读取的SubKey的名称
  77. 'cbName: 传入lpName的字符串长度?
  78. '返回值: =0,表示成功;≠0,表示失败。
  79. 'RegQueryValueEx --读取某Key的特定名称的值(Value)
  80. 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
  81. 'hkey: Key Handle
  82. 'lpValueName: Value Name
  83. 'lpReserved:保留参数,调用时设置为0即可
  84. 'lpType: 返回读取的数据类型
  85. 'lpData: 返回读取的数据,如果是REG_SZ类型,前面就必须加ByVal,否则程序崩溃,其它类型不能加ByVal
  86. 'lpcbData:传入lpData数据的长度,若成功读取数据,则返回所读取的数据的长度。
  87. '返回值: =0,表示成功;≠0,表示失败。
  88. '说明:
  89. '1、 这一函数除了可读取指定名称的值之外,也可以读取default value。如果要读取default value,只需要将
  90. '参数lpValueName设置为""[空字符串]即可。
  91. '2 ?lpType 的可能取值
  92. 'Enum ValueType
  93. 'REG_NONE = 0
  94. 'REG_SZ = 1 -->字符串
  95. 'REG_EXPAND_SZ = 2 -->可展开式字符串
  96. 'REG_BINARY = 3 -->Binary数据
  97. 'REG_DWORD = 4 -->长整数
  98. 'REG_DWORD_BIG_ENDIAN = 5 -->BIG_ENDIAN长整数
  99. 'REG_MULTI_SZ = 7 -->多重字符串
  100. 'End Enum
  101. Sub MultiStringToStringArray(S As String, S2() As String)
  102.     'S为我们读取出来的多重字符串
  103.     'S2为转换后的字符串数组
  104.     Dim count As Integer, pos As Integer, pos2 As Integer, idx As Integer
  105.     pos = InStr(S, Chr(0))
  106.     While pos > 0
  107.         count = count + 1
  108.         pos = InStr(pos + 1, S, Chr(0))
  109.     Wend
  110.     '取得多重字符串中的字符串个数
  111.     count = count - 1
  112.     ReDim S2(0 To count - 1)
  113.     pos = 1
  114.     For idx = 0 To count - 1
  115.         pos2 = InStr(pos, S, Chr(0))
  116.         S2(idx) = Mid(S, pos, pos2 - pos)
  117.         pos = pos2 + 1
  118.     Next
  119. End Sub
  120. '列举所有注册表项的值
  121. Public Function GetRegAllValue(RootKey As Long, SubKeyName As String) As String
  122.     Dim ret As Long, lenData As Long, typeData As Long, hKey As Long
  123.     Dim Name As String
  124.     Dim lenName As Long
  125.     Dim idx As Integer, j As Integer
  126.     Dim bName(256) As Byte
  127.     ret = RegOpenKey(RootKey, SubKeyName, hKey)
  128.     If ret <> 0 Then Exit Function
  129.     ret = 0
  130.     idx = 0
  131.     While ret = 0
  132.         lenName = 256
  133.         ret = RegEnumValue(hKey, idx, bName(0), lenName, ByVal 0, typeData, ByVal vbNullString, lenData)
  134.         If ret <> 0 Then
  135.             RegCloseKey hKey
  136.             Exit Function
  137.         End If
  138.         '上面的RegEnumValue调用得到了第一个Name的长度lenName,不含chr(0)
  139.         Name = String(lenName + 1, Chr(0))
  140.         lenName = Len(Name)
  141.         Select Case typeData
  142.             Case REG_SZ, REG_EXPAND_SZ, REG_MULTI_SZ
  143.             Dim S As String
  144.             S = String(lenData, Chr(0))
  145.             RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, ByVal S, lenData
  146.             If typeData = REG_SZ Then
  147.                 S = Left(S, InStr(S, Chr(0)) - 1)
  148.                 GetRegAllValue = GetRegAllValue & IIf(lenName = 0, "(预设值)", Left(Name, InStr(Name, Chr(0)) - 1)) & "=" & S & vbCrLf
  149.             ElseIf typeData = REG_EXPAND_SZ Then
  150.                 Dim S2 As String
  151.                 S2 = String(Len(S) + 256, Chr(0))
  152.                 ExpandEnvironmentStrings S, S2, Len(S2)
  153.                 S = Left(S2, InStr(S2, Chr(0)) - 1)
  154.                 GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = " & S & vbCrLf
  155.             ElseIf typeData = REG_MULTI_SZ Then
  156.                 Dim SArr() As String
  157.                 MultiStringToStringArray S, SArr
  158.                 For j = 0 To UBound(SArr)
  159.                     GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & "(" & j & ") = " & SArr(j) & vbCrLf
  160.                 Next
  161.             End If
  162.             Case REG_DWORD, REG_DWORD_BIG_ENDIAN
  163.             Dim L As Long
  164.             RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, L, lenData
  165.             GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = " & L & vbCrLf
  166.             Case REG_BINARY
  167.             ReDim bArr(0 To lenData - 1) As Byte
  168.             RegEnumValue hKey, idx, Name, lenName, ByVal 0, typeData, bArr(0), lenData
  169.             GetRegAllValue = GetRegAllValue & Left(Name, InStr(Name, Chr(0)) - 1) & " = "
  170.             For j = 0 To UBound(bArr)
  171.                 GetRegAllValue = GetRegAllValue & Hex(bArr(j)) & " "
  172.             Next
  173.             GetRegAllValue = GetRegAllValue & vbCrLf
  174.         End Select
  175.         idx = idx + 1
  176.     Wend
  177.     RegCloseKey hKey
  178. End Function
  179. '判断注册项是否存在
  180. Public Function IsSubKeyName(RootKey As Long, SubKeyName As String, Optional hKey As Long) As Boolean
  181.     If RegOpenKey(RootKey, SubKeyName, hKey) = 0& Then
  182.         IsSubKeyName = True
  183.     Else
  184.         IsSubKeyName = False
  185.     End If
  186. End Function
复制代码
[ 本帖最后由 icecept 于 2009-1-13 17:01 编辑 ]

注册表语句应用示例终级完美版.rar

6.12 KB, 下载次数: 1875

评分

参与人数 2威望 +11 收起 理由
gbm + 1 发布源码
54jb + 10 发布源码

查看全部评分

回复 支持 反对

使用道具 举报

发表于 2008-4-5 09:57:16 | 显示全部楼层
恩。恩。恩。。

以前写过自己分析注册表HIVE格式的代码。。
回复 支持 反对

使用道具 举报

 楼主| 发表于 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 编辑 ]
回复 支持 反对

使用道具 举报

 楼主| 发表于 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 编辑 ]
回复 支持 反对

使用道具 举报

 楼主| 发表于 2008-4-30 12:21:39 | 显示全部楼层

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

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



  1. 此程序功能是把电脑中的应用都锁住不让运行,只让运行杀毒软件、注册表、explorer和本程序。

  2. 友情提示:此程序具有一定的危险性,请新手不要擅自模仿。如果为此而造成损失,本
  3. 作者将不承担任何责任。

  4. 在窗体中:

  5. '**************************************************************************
  6. '**模 块 名:限制程序运行 - Form1
  7. '**说    明:魔灵圣域 版权所有2008 - 2009(C)
  8. '**创 建 人:郭卫(魔灵)
  9. '**日    期:2008-04-30 00:33:12
  10. '**修 改 人:郭卫
  11. '**日    期:
  12. '**描    述:郭卫制作
  13. '**版    本:V1.0.0    http:/blog.sina.com.cn/icecept
  14. '*************************************************************************
  15. Option Explicit
  16. Private Const HKEY_CURRENT_USER = &H80000001
  17. Private Const REG_SZ = 1                    '    -->字符串
  18. Private Const REG_DWORD = 4                ' -->长整数
  19. Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  20. Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
  21. 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.
  22. Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  23. Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  24. Private hKey As Long
  25. Private Sub Command1_Click()
  26.     '建立禁止运行任何程序
  27.     RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
  28.     RegSetValueEx hKey, "RestrictRun", 0, REG_DWORD, 1&, 4
  29.     RegCreateKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\RestrictRun", hKey
  30.    
  31.     '建立充许运行的的程序,以下三个键值极为重要,它是为自己留的后门,否则你就重装系统吧
  32.     RegSetValueEx hKey, "Onlyme", 0, REG_SZ, ByVal "Onlyme.exe", LenB(StrConv("Onlyme.exe", vbFromUnicode)) + 1
  33.     RegSetValueEx hKey, "注册表", 0, REG_SZ, ByVal "regedit.exe", LenB(StrConv("regedit.exe", vbFromUnicode)) + 1
  34.     RegSetValueEx hKey, "Explorer", 0, REG_SZ, ByVal "Explorer.exe", LenB(StrConv("Explorer.exe", vbFromUnicode)) + 1
  35.     RegCloseKey hKey
  36.     RebootExplorer
  37. End Sub
  38. Private Sub Command2_Click()
  39.     '建立充许运行任何程序
  40.     RegOpenKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer", hKey
  41.     RegSetValueEx hKey, "RestrictRun", 0, REG_DWORD, 0&, 4
  42.     RegDeleteKey HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\RestrictRun"
  43.     RebootExplorer
  44. End Sub
复制代码


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



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



[ 本帖最后由 icecept 于 2009-1-13 17:08 编辑 ]
回复 支持 反对

使用道具 举报

发表于 2008-5-8 09:19:17 | 显示全部楼层
好东西,仔细研究下!
回复 支持 反对

使用道具 举报

发表于 2008-5-18 11:02:30 | 显示全部楼层
好贴!
收藏学习!
回复 支持 反对

使用道具 举报

发表于 2008-5-21 13:38:10 | 显示全部楼层
好东东以前可是打着灯笼都难找啊
回复 支持 反对

使用道具 举报

头像被屏蔽
发表于 2008-5-21 14:02:20 | 显示全部楼层
好贴!  收藏了,谢谢!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2019-11-22 20:57

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表