form1.frm

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

        Exit Sub
    End If
    Shell "notepad.exe reglog.log", vbNormalFocus
End Sub

Private Sub Command6_Click()
    List1.Clear
    List2.Clear
    List3.Clear
    List4.Clear
    
    If Text1.Text = "" Then
        MsgBox "文本框内容不能为空！"
        Exit Sub
    End If
    
    Dim hkey As Long, ret As Long, Name As String, Idx As Long, i, j As Integer
    Dim Str_List2 As String
    
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID", hkey)
    
    j = 0
    Idx = 0
    Name = String(256, Chr(0))
    Do
        ret = RegEnumKey(hkey, Idx, Name, Len(Name))
        
        If ret = 0 Then
            List1.AddItem Left(Name, InStr(Name, Chr(0)) - 1)
            Idx = Idx + 1
        End If
        
        DoEvents
        Label1.Caption = "正在查找组件注册信息..."
    Loop Until ret <> 0
    
    RegCloseKey hkey
    
    For i = 0 To List1.ListCount
        List2.AddItem Func_ReadRegAndGetFileName(List1.List(i))
    Next
    
    For i = 0 To List2.ListCount
        Str_List2 = Func_GetFileNameFormPath(List2.List(i))
        
        '判断是否与指定的ocx相同
        If LCase(Str_List2) = LCase(Text1.Text) Then
            DoEvents
            
            List3.AddItem Str_List2 + "的注册信息已经删除！"
            j = j + 1
            '查找Lib位置上的东东并删除
             Func_DelRegTypeLib (i)
             
            '删除程序调用ocx时必须用的信息
            Call RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\CLSID\", hkey)
            DeleteSubkeyTree hkey, List1.List(i)
            
        End If
        
        If j > 0 Then Label1.Caption = "正在删除组件注册信息..."
        
    Next
    If j > 0 Then
        Label1.Caption = "组件注册信息删除完成！"
    Else
        Label1.Caption = "组件注册信息未找到！"
    End If
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Drive1_Change()
    On Error Resume Next
    Dir1.Path = Drive1.Drive
    
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

'从路径中取出文件名
Private Function Func_GetFileNameFormPath(Str_Path As String) As String
    Dim i As Integer
    For i = 0 To Len(Str_Path)
        If i = Len(Str_Path) - 1 Then Func_GetFileNameFormPath = Str_Path
        If Left(Right(Str_Path, i), 1) = "\" Then
            Func_GetFileNameFormPath = Right(Str_Path, i - 1)
            i = Len(Str_Path)
        End If
    Next
End Function

'读键的值并取文件名
Private Function Func_ReadRegAndGetFileName(Str_filereg As String) As String
    Dim ret, hkey As Long
    Str_filereg = "SOFTWARE\Classes\CLSID\" + Str_filereg
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, Str_filereg, hkey)
    
    Dim s As String, lens As Long
    lens = 255
    s = String(lens, Chr(0))
    Call RegQueryValue(hkey, "InprocServer32", s, lens)
    Func_ReadRegAndGetFileName = s
    
    RegCloseKey hkey
    
End Function

'删除Visual Basic调用ocx时必须用的信息
Private Function Func_DelRegTypeLib(i As Integer) As String
    Dim ret, hkey As Long, Str_filereg As String
    Str_filereg = "SOFTWARE\Classes\CLSID\" + List1.List(i)
    ret = RegOpenKey(HKEY_LOCAL_MACHINE, Str_filereg, hkey)
    
    Dim s As String, lens As Long
    lens = 255
    s = String(lens, Chr(0))
    Call RegQueryValue(hkey, "TypeLib", s, lens)
    
    s = Left(s, InStr(s, Chr(0)) - 1)
    
    '删除vb调用ocx时必须用的信息
    If Len(s) <> 0 Then
        List4.AddItem "已删除！" + s
        Call RegOpenKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\TypeLib\", hkey)
        DeleteSubkeyTree hkey, s
    End If
    
    RegCloseKey hkey
    
End Function

'注册注销组件
Private Function RegDLL_OCX(File As String, Optional Process As RegUnreg = register, Optional PromptOnError As Boolean = False) As Boolean
    On Error Resume Next

    Dim LoadedLib As Long, EntryPoint As Long, ExitCode As Long
    Dim newThread As Long, newThreadID As Long
    
    If Dir(File) = "" Then
       MsgBox "文件名未找到！", vbCritical
       Exit Function
    End If
    
    LoadedLib = LoadLibrary(File)                          ' 载入文件

    If LoadedLib = 0 Then
        If PromptOnError Then MsgBox "载入文件时发生错误！", vbCritical
        RegDLL_OCX = False
        
        Call Sub_WriteText(File, Process, RegDLL_OCX)
        
        Exit Function
    End If

    '查找入口点
    If Process = register Then
        EntryPoint = GetProcAddress(LoadedLib, "DllRegisterServer")
    ElseIf Process = unregister Then
        EntryPoint = GetProcAddress(LoadedLib, "DllUnregisterServer")
    Else
        If PromptOnError Then MsgBox "载入文件时发生错误！", vbCritical
        RegDLL_OCX = False
        
        Call Sub_WriteText(File, Process, RegDLL_OCX)
        
        Exit Function
    End If
    
    If EntryPoint = vbNull Then
        If PromptOnError Then MsgBox "查找文件入口点时发生错误！: " & vbNewLine & File, vbCritical
        FreeLibrary (LoadedLib)                            '退出
        RegDLL_OCX = False
        
        Call Sub_WriteText(File, Process, RegDLL_OCX)
        
        Exit Function
    End If

    Screen.MousePointer = vbHourglass

    newThread = CreateThread(ByVal 0, 0, ByVal EntryPoint, ByVal 0, 0, newThreadID)    '建立新的进程

    If newThread = 0 Then
        Screen.MousePointer = vbDefault
        If PromptOnError Then MsgBox "建立新的进程发生错误!", vbCritical
        FreeLibrary (LoadedLib)                            '退出
        Exit Function
    End If

    If WaitForSingleObject(newThread, 10000) <> 0 Then
        Screen.MousePointer = vbDefault
        If PromptOnError Then MsgBox "注册/反注册文件时发生错误！: " & vbNewLine & File, vbCritical
        ExitCode = GetExitCodeThread(newThread, ExitCode)
        ExitThread (ExitCode)
        FreeLibrary (LoadedLib)
        RegDLL_OCX = False
        Exit Function
    End If

    CloseHandle (newThread)                                '关闭线程
    FreeLibrary (LoadedLib)                                '退出
    Screen.MousePointer = vbDefault                        '重置光标
    RegDLL_OCX = True
    
    Call Sub_WriteText(File, Process, RegDLL_OCX)
End Function

'写入日志
Private Sub Sub_WriteText(Str_file As String, Bool_RegOcx As RegUnreg, Bool_YN As Boolean)
    ChDir File1.Path
    
    Str_file = Right(Str_file, Len(Str_file) - Len(File1.Path) - 1)
    Str_file = RTrim(Str_file)
    
    Open File1.Path + "\Reglog.log" For Append As #1
        If Bool_RegOcx = register Then
            If Bool_YN Then
                Print #1, Str_file, "注册成功! "
                List3.AddItem Str_file + "注册成功! "
            Else
                Print #1, Str_file, "注册失败! "
                List3.AddItem Str_file + "注册失败! "
            End If
        Else
            If Bool_YN Then
                Print #1, Str_file, "注销成功! "
                List3.AddItem Str_file + "注销成功! "
            Else
                Print #1, Str_file, "注销失败! "
                List3.AddItem Str_file + "注销失败! "
            End If
        End If
    Close #1
    
End Sub