应用程序加入右键菜单和删除右键菜单

SKY定格

消除用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://icecept.blog.sohu.com '************************************************************************* 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 添加启动项和删除启动项 '************************************************************************** '**模 块 名：工程1 - Form1 '**说 明：魔灵圣域   by icecept(郭卫） '**创 建 人：icecept(魔灵) '**日 期：2009-02-09 11:30:19 '**修 改 人：icecept(魔灵) '**版 本：V1.0.0 '**E-mail   ：icecept@163.com QQ：543375508 '**网 址：http://hi.baidu.com/icecept    http://hi.csdn.net/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