form1.frm

能让你实现轻松注册组建！更多联系QQ417317494 www.sfjiang.cn 姜斌

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "注册组件"
   ClientHeight    =   1800
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3855
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   1800
   ScaleWidth      =   3855
   StartUpPosition =   1  '所有者中心
   Begin VB.CommandButton Command2 
      Appearance      =   0  'Flat
      Caption         =   "取消"
      Height          =   375
      Left            =   1980
      TabIndex        =   4
      Top             =   1320
      Width           =   1095
   End
   Begin VB.CommandButton Command1 
      Appearance      =   0  'Flat
      Caption         =   "确定"
      Height          =   375
      Left            =   660
      TabIndex        =   3
      Top             =   1320
      Width           =   1095
   End
   Begin VB.Frame Frame1 
      Height          =   1155
      Left            =   60
      TabIndex        =   0
      Top             =   0
      Width           =   3735
      Begin VB.OptionButton Option2 
         Caption         =   "删除组件注册/反注册菜单"
         Height          =   375
         Left            =   600
         TabIndex        =   2
         Top             =   660
         Width           =   2535
      End
      Begin VB.OptionButton Option1 
         Caption         =   "添加组件注册/反注册菜单"
         Height          =   375
         Left            =   600
         TabIndex        =   1
         Top             =   240
         Value           =   -1  'True
         Width           =   2595
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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 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
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 RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1&
Const ERROR_BADKEY = 2&
Const ERROR_CANTOPEN = 3&
Const ERROR_CANTREAD = 4&
Const ERROR_CANTWRITE = 5&
Const ERROR_OUTOFMEMORY = 6&
Const ERROR_INVALID_PARAMETER = 7&
Const ERROR_ACCESS_DENIED = 8&

Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const MAX_PATH = 260&
Private Const REG_SZ = 1
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private 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

Private Sub Command1_Click()
    Dim hKey As Long
    If Option1.Value = True Then
        Sub_AddMenu
        MsgBox "添加菜单成功！", vbInformation
    Else
        Call RegOpenKey(HKEY_CLASSES_ROOT, "ocxfile", hKey)
        DeleteSubkeyTree hKey, "shell"
        Call RegCloseKey(hKey)
        
        Call RegOpenKey(HKEY_CLASSES_ROOT, "dllfile", hKey)
        DeleteSubkeyTree hKey, "shell"
        Call RegCloseKey(hKey)

        MsgBox "删除菜单成功！", vbInformation
    End If
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Sub_AddMenu()
    Dim sKeyName As String      'Holds Key Name in registry.
    Dim sKeyValue As String     'Holds Key Value in registry.
    Dim ret&                    'Holds error status if any from API calls.
    Dim lphKey&                 'Holds created key handle from RegCreateKey.
    
    '注册ocx
    sKeyName = "ocxfile"
    sKeyValue = "regsvr32 %1"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    
    ret& = RegSetValue&(lphKey&, "shell\reg", REG_SZ, "注册组件(&R)", MAX_PATH)
    ret& = RegSetValue&(lphKey&, "shell\reg\command", REG_SZ, sKeyValue, MAX_PATH)
    
    sKeyValue = "regsvr32 -u %1"
    ret& = RegSetValue&(lphKey&, "shell\Unreg", REG_SZ, "注销组件(&U)", MAX_PATH)
    ret& = RegSetValue&(lphKey&, "shell\Unreg\command", REG_SZ, sKeyValue, MAX_PATH)
    ret& = RegCloseKey(lphKey&)
    
    '注册dll
    sKeyName = "dllfile"
    sKeyValue = "regsvr32 %1"
    ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
    
    ret& = RegSetValue&(lphKey&, "shell\reg", REG_SZ, "注册组件(&R)", MAX_PATH)
    ret& = RegSetValue&(lphKey&, "shell\reg\command", REG_SZ, sKeyValue, MAX_PATH)
    
    sKeyValue = "regsvr32 -u %1"
    ret& = RegSetValue&(lphKey&, "shell\Unreg", REG_SZ, "注销组件(&U)", MAX_PATH)
    ret& = RegSetValue&(lphKey&, "shell\Unreg\command", REG_SZ, sKeyValue, MAX_PATH)
    
    ret& = RegCloseKey(lphKey&)

End Sub

'删除键下在的所有子键
 Function DeleteSubkeyTree(ByVal hKey As Long, ByVal Subkey As String) As Boolean
    Dim ret As Long, Index As Long, Name As String
    Dim hSubKey As Long
    
    ret = RegOpenKey(hKey, Subkey, hSubKey)
    
    
    If ret <> 0 Then
        DeleteSubkeyTree = False
        'MsgBox "failure!"
        Exit Function
    End If
    
    ret = RegDeleteKey(hSubKey, "")

    If ret <> 0 Then
        Name = String(256, Chr(0))
        'MsgBox "RegDeleteKey无法删除，用于Winnt下。"
        While RegEnumKey(hSubKey, 0, Name, Len(Name)) = 0 And DeleteSubkeyTree(hSubKey, Name)
            '递归删除Subkey的Subkey
        Wend
        ret = RegDeleteKey(hSubKey, "")
    End If
    
    DeleteSubkeyTree = (ret = 0)
    RegCloseKey hSubKey
End Function