Chip 2002 February/Chip_2002-02_cd1.bin/zkuste/vbasic/Data/Utility/RegWiz.exe/Dev/RegWiz/RegWiz.frm

Visual Basic Form | 2000-01-27 | 12KB | 308 lines

VERSION 5.00
Begin VB.Form frmRegWiz
   Caption         =   "Registration Wizard"
   ClientHeight    =   3975
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4935
   LinkTopic       =   "Form1"
   ScaleHeight     =   3975
   ScaleWidth      =   4935
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdUnReg
      Caption         =   "&UnRegister"
      Height          =   315
      Left            =   3900
      TabIndex        =   7
      Top             =   3600
      Width           =   975
   End
   Begin VB.CheckBox chkRecurse
      Caption         =   "R&ecurse into Sub-Directories"
      Height          =   195
      Left            =   1320
      TabIndex        =   6
      Top             =   3660
      Width           =   2475
   End
   Begin VB.TextBox txtFilter
      Height          =   285
      Left            =   840
      TabIndex        =   2
      Text            =   "Ocx,Exe,Dll,Tlb"
      Top             =   420
      Width           =   2955
   End
   Begin VB.CommandButton cmdReg
      Caption         =   "&Register"
      Height          =   315
      Left            =   3900
      TabIndex        =   5
      Top             =   3600
      Width           =   975
   End
   Begin VB.TextBox txtDir
      BackColor       =   &H8000000F&
      Height          =   285
      Left            =   840
      Locked          =   -1  'True
      TabIndex        =   0
      TabStop         =   0   'False
      Text            =   "Text1"
      Top             =   60
      Width           =   4035
   End
   Begin VB.TextBox txtLog
      BackColor       =   &H80000000&
      Height          =   2715
      Left            =   0
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   4
      Text            =   "RegWiz.frx":0000
      Top             =   780
      Width           =   4875
   End
   Begin VB.Label Label2
      Caption         =   "&Filter"
      Height          =   255
      Left            =   0
      TabIndex        =   3
      Top             =   480
      Width           =   795
   End
   Begin VB.Label Label1
      Caption         =   "Directory"
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   120
      Width           =   795
   End
Attribute VB_Name = "frmRegWiz"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const MODULE_NAME = "frmRegWiz"
Private msFilter As String
Private Err As New CGUIErr
'Start the registration Register. Directories will be recursed
'if requested.
'FileSystemObject is used to make life easier.
Private Sub cmdReg_Click()
On Error GoTo ErrHandler
Dim oFS As FileSystemObject
Dim oFolder As Folder
    Screen.MousePointer = vbHourglass
        Set oFS = New FileSystemObject
        Set oFolder = oFS.GetFolder(txtDir.Text)
        msFilter = Trim$(txtFilter.Text) & ","

        RegisterFolder oFolder, Register:=True
    Screen.MousePointer = vbDefault
    Exit Sub
ErrHandler: Err.Show ProcName:=MODULE_NAME & ".cmdReg_Click"
End Sub
Private Sub cmdUnReg_Click()
On Error GoTo ErrHandler
Dim oFS As FileSystemObject
Dim oFolder As Folder
    Screen.MousePointer = vbHourglass
        Set oFS = New FileSystemObject
        Set oFolder = oFS.GetFolder(txtDir.Text)
        msFilter = Trim$(txtFilter.Text) & ","

        RegisterFolder oFolder, Register:=False
    Screen.MousePointer = vbDefault
    Exit Sub
ErrHandler: Err.Show ProcName:=MODULE_NAME & ".cmdUnReg_Click"
End Sub
'Create the default form settings
Private Sub Form_Load()
On Error GoTo ErrHandler
    Dim sMyCmd As String
    Dim sCmdRequest As String
    Dim oFS As FileSystemObject
    Dim bRegister
    Set oFS = New FileSystemObject
    txtFilter.Text = GetKeyValue(HKEY_CURRENT_USER, REGISTRY_PATH, REGISTRY_KEY_FILTER)
    If txtFilter.Text = vbNullString Then txtFilter.Text = "Dll,Exe,Ocx,Tlb"
    chkRecurse.Value = (1 And GetKeyValue(HKEY_CURRENT_USER, REGISTRY_PATH, REGISTRY_KEY_RECURSE) = "1")
    txtLog.Text = vbNullString
    'Grab the command string and determine if a Registration or Unregistration needed.
    sCmdRequest = Trim$(Command$)
    If UCase$(Left$(sCmdRequest, 2) = "-U") Then
        bRegister = False
        sCmdRequest = Trim$(Mid$(sCmdRequest, 3))
    Else
        bRegister = True
    End If
    'Strip out the quotes from a parameter if they were typed by a user
    If Left$(sCmdRequest, 1) = """" Then sCmdRequest = Mid$(sCmdRequest, 2, Len(sCmdRequest) - 2)
    'Three possible actions:
    '  1. Started standalone to register it
    '  2. A Directory name has been supplied
    '  3. A File name has been supplied
    If sCmdRequest = vbNullString Then
        'Hook into the Registry for Registering TLIBs
        sMyCmd = App.Path & "\" & App.EXEName & ".Exe %1"
        UpdateKeyValue HKEY_CLASSES_ROOT, "dllFile\shell\Register\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "exeFile\shell\Register\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "Folder\shell\Register Directory\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "ocxFile\shell\Register\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "tlb_auto_File\shell\Register\command", "", sMyCmd

        'Hook into the Registry for UnRegistering TLIBs
        sMyCmd = App.Path & "\" & App.EXEName & ".Exe -U %1"
        UpdateKeyValue HKEY_CLASSES_ROOT, "dllFile\shell\UnRegister\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "exeFile\shell\UnRegister\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "Folder\shell\UnRegister Directory\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "ocxFile\shell\UnRegister\command", "", sMyCmd
        UpdateKeyValue HKEY_CLASSES_ROOT, "tlb_auto_File\shell\UnRegister\command", "", sMyCmd

        MsgBox "RegWiz has been registered successfully", vbOKOnly, "RegWiz - Information"
        Unload Me

    ElseIf oFS.FileExists(sCmdRequest) Then
        If bRegister Then RegisterFile sCmdRequest Else UnRegisterFile sCmdRequest
        Unload Me
    ElseIf oFS.FolderExists(sCmdRequest) Then
        'Carry on and show
        txtDir.Text = sCmdRequest

        'Display the correct buttons
        cmdReg.Visible = bRegister
        cmdUnReg.Visible = Not bRegister

    Else
        MsgBox "Cannot find a file or folder called " & sCmdRequest, vbOKOnly, "RegWiz - Error"
        Unload Me
    End If

    Exit Sub
ErrHandler: Err.Show ProcName:=MODULE_NAME & ".Form_Load"
End Sub
'Register all of the files in the folder that match the filter.
'Attempt to open the TypeLibrary for the file and then register that type library.
Private Sub RegisterFolder(ByVal Folder As Folder, Optional ByVal Register As Boolean = True)
Dim oTlib As TypeLibInfo
Dim oTLApp As TLIApplication
Dim oFile As File
Dim oNewFolder As Folder
Dim sIndent As String
    'The procedure recurses. This will be used to indent the log text
    Static iDepth As Integer
    sIndent = Space$(iDepth)
    iDepth = iDepth + 1
    Log sIndent & Folder.Path & "\" & vbCrLf
    For Each oFile In Folder.Files
        'Register any that match the filter
        If InStr(1, msFilter, Mid$(oFile.Path, InStrRev(oFile.Path, ".") + 1) & ",", vbTextCompare) > 0 Then

            Set oTLApp = New TLIApplication

            'Load the Typelibrary if there is one
            On Error Resume Next
            Set oTlib = oTLApp.TypeLibInfoFromFile(oFile.Path)

            'If there is a type library then register it.
            If Err.Number = 0 Then
                Err.Clear
                If Register Then
                    oTlib.Register
                    If Err.Number = 0 Then
                         Log sIndent & oFile.Name & "  - OK " & vbCrLf
                    Else
                        Log sIndent & oFile.Name & " REGISTRATION failed" & vbCrLf
                    End If
                Else
                    oTlib.UnRegister
                    If Err.Number = 0 Then
                         Log sIndent & oFile.Name & "  - Unregister OK " & vbCrLf
                    Else
                        Log sIndent & oFile.Name & " UNREGISTRATION failed" & vbCrLf
                    End If
                End If
            DoEvents
            End If

        End If
    Next oFile
    'Recurse into the child folders if that was requested
    If chkRecurse.Value = vbChecked Then
        For Each oNewFolder In Folder.SubFolders
            RegisterFolder oNewFolder, Register
        Next oNewFolder
    End If
    iDepth = iDepth - 1
    Exit Sub
ErrHandler: Err.Raise ProcName:=MODULE_NAME & ".RegisterFolder"
End Sub
'Writes text to the Log. Scrolls the log as it goes
Private Sub Log(ByVal Text As String)
On Error GoTo ErrHandler
    txtLog.Text = txtLog.Text & Text
    txtLog.SelStart = Len(txtLog.Text)
    Exit Sub
ErrHandler: Err.Raise ProcName:=MODULE_NAME & ".Log"
End Sub
'Save the form settings
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo ErrHandler
    Call UpdateKeyValue(HKEY_CURRENT_USER, REGISTRY_PATH, REGISTRY_KEY_FILTER, txtFilter.Text)
    Call UpdateKeyValue(HKEY_CURRENT_USER, REGISTRY_PATH, REGISTRY_KEY_RECURSE, chkRecurse.Value)
    Exit Sub
ErrHandler: Err.Show ProcName:=MODULE_NAME & ".Form_Unload"
End Sub
Private Sub RegisterFile(ByVal Filename As String)
Dim oTlib As TypeLibInfo
Dim oTLApp As TLIApplication

    Set oTLApp = New TLIApplication

    'Load the Typelibrary if there is one
    On Error Resume Next
    Set oTlib = oTLApp.TypeLibInfoFromFile(Filename)
    'If there is a type library then register it.
    If Err.Number = 0 Then
        Err.Clear
        oTlib.Register
        If Err.Number = 0 Then
             MsgBox Filename & " has been registered", vbOKOnly, "RegWiz - Information"
        Else
            MsgBox Filename & " failed to register, even though it contains a Type Library", vbOKOnly, "RegWiz - File Error"
        End If
    Else
        MsgBox Filename & " does not contain a valid Type library", vbOKOnly, "RegWiz - File Error"
    End If
    Exit Sub
ErrHandler: Err.Raise ProcName:=MODULE_NAME & ".RegisterFile"
End Sub
Private Sub UnRegisterFile(ByVal Filename As String)
Dim oTlib As TypeLibInfo
Dim oTLApp As TLIApplication

    Set oTLApp = New TLIApplication

    'Load the Typelibrary if there is one
    On Error Resume Next
    Set oTlib = oTLApp.TypeLibInfoFromFile(Filename)
    'If there is a type library then register it.
    If Err.Number = 0 Then
        Err.Clear
        oTlib.UnRegister
        If Err.Number = 0 Then
             MsgBox Filename & " has been Unregistered", vbOKOnly, "RegWiz - Information"
        Else
            MsgBox Filename & " failed to Unregister, even though it contains a Type Library", vbOKOnly, "RegWiz - File Error"
        End If
    Else
        MsgBox Filename & " does not contain a valid Type library", vbOKOnly, "RegWiz - File Error"
    End If
    Exit Sub
ErrHandler: Err.Raise ProcName:=MODULE_NAME & ".UnRegisterFile"
End Sub