vbAccelerator - Contents of code file: frmManageTypeLib.frm

VERSION 5.00
Begin VB.Form frmManageTypeLib 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Manage Type Libraries"
   ClientHeight    =   6480
   ClientLeft      =   5640
   ClientTop       =   3690
   ClientWidth     =   6360
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6480
   ScaleWidth      =   6360
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdCopy 
      Caption         =   "&Save as XML"
      Height          =   435
      Left            =   2160
      TabIndex        =   12
      Top             =   6000
      Width           =   1275
   End
   Begin VB.CommandButton cmdDelete 
      Caption         =   "&Delete"
      Height          =   435
      Left            =   3540
      TabIndex        =   11
      Top             =   6000
      Width           =   1275
   End
   Begin VB.Frame fraSep 
      Height          =   75
      Left            =   -840
      TabIndex        =   10
      Top             =   5880
      Width           =   7335
   End
   Begin VB.CommandButton cmdOK 
      Cancel          =   -1  'True
      Caption         =   "Close"
      Height          =   435
      Left            =   5040
      TabIndex        =   9
      Top             =   6000
      Width           =   1275
   End
   Begin VB.TextBox txtInfo 
      BackColor       =   &H8000000F&
      Height          =   315
      Index           =   3
      Left            =   60
      Locked          =   -1  'True
      TabIndex        =   7
      Top             =   5100
      Width           =   4695
   End
   Begin VB.TextBox txtInfo 
      BackColor       =   &H8000000F&
      Height          =   315
      Index           =   0
      Left            =   60
      Locked          =   -1  'True
      TabIndex        =   3
      Top             =   3180
      Width           =   4695
   End
   Begin VB.TextBox txtInfo 
      BackColor       =   &H8000000F&
      Height          =   315
      Index           =   1
      Left            =   60
      Locked          =   -1  'True
      TabIndex        =   2
      Top             =   3780
      Width           =   4695
   End
   Begin VB.TextBox txtInfo 
      BackColor       =   &H8000000F&
      Height          =   315
      Index           =   2
      Left            =   60
      Locked          =   -1  'True
      TabIndex        =   1
      Top             =   4440
      Width           =   4695
   End
   Begin VB.ListBox lstTypeLibs 
      Height          =   2790
      Left            =   60
      Sorted          =   -1  'True
      TabIndex        =   0
      Top             =   60
      Width           =   6255
   End
   Begin VB.Label lblInfo 
      Caption         =   "Path:"
      Height          =   255
      Index           =   3
      Left            =   60
      TabIndex        =   8
      Top             =   4860
      Width           =   1095
   End
   Begin VB.Label lblInfo 
      Caption         =   "Name:"
      Height          =   255
      Index           =   0
      Left            =   60
      TabIndex        =   6
      Top             =   2940
      Width           =   495
   End
   Begin VB.Label lblInfo 
      Caption         =   "GUID:"
      Height          =   255
      Index           =   1
      Left            =   60
      TabIndex        =   5
      Top             =   3540
      Width           =   495
   End
   Begin VB.Label lblInfo 
      Caption         =   "Version:"
      Height          =   255
      Index           =   2
      Left            =   60
      TabIndex        =   4
      Top             =   4200
      Width           =   1095
   End
End
Attribute VB_Name = "frmManageTypeLib"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private m_frmParent As Form

Public Property Let ParentForm(ByRef frmThis As Form)
   Set m_frmParent = frmThis
End Property

Private Property Get ObjectFromPtr(ByVal lPtr As Long) As cTypeLibInfo
Dim objT As cTypeLibInfo
   ' Bruce McKinney's code for getting an Object from the
   ' object pointer:
   CopyMemory objT, lPtr, 4
   Set ObjectFromPtr = objT
   CopyMemory objT, 0&, 4
End Property

Public Sub Populate()
Dim iSectCount As Long, iSect As Long, sSections() As String
Dim iVerCount As Long, iVer As Long, sVersions() As String
Dim iExeSectCount As Long, sExeSect() As String
Dim iExeSect As Long
Dim bFoundExeSect As Boolean
Dim sExists As String
Dim cTLI As cTypeLibInfo
Dim i As IShellFolderEx_TLB.IUnknown

   pClearList
   lstTypeLibs.Clear
   lstTypeLibs.Visible = False

   Dim cR As New cRegistry
   cR.ClassKey = HKEY_CLASSES_ROOT
   cR.ValueType = REG_SZ
   cR.SectionKey = "TypeLib"
   ' Get the registered Type Libs:
   If cR.EnumerateSections(sSections(), iSectCount) Then
      For iSect = 1 To iSectCount
         ' Enumerate the versions for each typelib:
         cR.SectionKey = "TypeLib\" & sSections(iSect)
         If cR.EnumerateSections(sVersions(), iVerCount) Then
            For iVer = 1 To iVerCount
               Set cTLI = New cTypeLibInfo
               cTLI.CLSID = sSections(iSect)
               cTLI.Ver = sVersions(iVer)
               cR.SectionKey = "TypeLib\" & sSections(iSect) & "\" &
                sVersions(iVer)
               cTLI.Name = cR.Value
               cR.EnumerateSections sExeSect(), iExeSectCount
               If iExeSectCount > 0 Then
                  bFoundExeSect = False
                  For iExeSect = 1 To iExeSectCount
                     If IsNumeric(sExeSect(iExeSect)) Then
                        cR.SectionKey = cR.SectionKey & "\" &
                         sExeSect(iExeSect) & "\win32"
                        bFoundExeSect = True
                        Exit For
                     End If
                  Next iExeSect
                  If bFoundExeSect Then
                     cTLI.Path = cR.Value
                     If FileExists(cTLI.Path) Then
                        sExists = "Y"
                     Else
                        sExists = "N"
                     End If
                  Else
                     sExists = "N"
                  End If
               Else
                  sExists = "N"
               End If
               cTLI.Exists = (StrComp(sExists, "Y") = 0)
               If Len(cTLI.Name) > 0 Then
                  lstTypeLibs.AddItem cTLI.Name & vbTab & sExists
               Else
                  lstTypeLibs.AddItem cTLI.CLSID & vbTab & sExists
               End If
               lstTypeLibs.ItemData(lstTypeLibs.NewIndex) = ObjPtr(cTLI)
               Set i = cTLI
               i.AddRef
            Next iVer
         End If
      Next iSect
   End If
   
   lstTypeLibs.Visible = True
   
End Sub

Private Sub pDeleteEntry(ByVal lPtr As Long)
Dim cTLI As cTypeLibInfo
   
   Set cTLI = ObjectFromPtr(lPtr)
   Dim cR As New cRegistry
   cR.ClassKey = HKEY_CLASSES_ROOT
   cR.SectionKey = "TypeLib\" & cTLI.CLSID & "\" & cTLI.Ver
   
   On Error Resume Next
   If cR.DeleteKey Then
      If Err.Number = 0 Then
         MsgBox "Successfully deleted the item " & cTLI.Name & ", version " &
          cTLI.Ver, vbInformation
      End If
   End If
   Err.Clear
   On Error GoTo 0
   
End Sub

Private Sub pClearList()
Dim lI As Long
Dim lPtr As Long
Dim i As IShellFolderEx_TLB.IUnknown
Dim cTLI As cTypeLibInfo

   For lI = 0 To lstTypeLibs.ListCount - 1
      lPtr = lstTypeLibs.ItemData(lI)
      If Not (lPtr = 0) Then
         Set cTLI = ObjectFromPtr(lPtr)
         Set i = cTLI
         i.Release
         Set i = Nothing
         Set cTLI = Nothing
      End If
   Next lI

End Sub

Private Sub cmdCopy_Click()
Dim i As Long
Dim lPtr As Long
Dim sXml As String
Dim cTLI As cTypeLibInfo
Dim sFile As String

   VBGetSaveFileName sFile, , , "XML Files (*.XML)|*.XML|All Files (*.*)|*.*",
    , , , "XML", Me.hWnd
   If (sFile <> "") Then

      sXml = "<?xml version=""1.0"" encoding=""UTF-8""?>"
      sXml = sXml & "<TypeLibs>" & vbCrLf
      For i = 0 To lstTypeLibs.ListCount - 1
         lPtr = lstTypeLibs.ItemData(i)
         If Not lPtr = 0 Then
            Set cTLI = ObjectFromPtr(lPtr)
            sXml = sXml & cTLI.ToXml() & vbCrLf
         End If
      Next i
      sXml = sXml & "</TypeLibs>" & vbCrLf
      
      On Error Resume Next
      ' try
      Kill sFile
      ' catch
      Err.Clear
      
      Dim iFile As Long
      iFile = FreeFile
      ' try
      Open sFile For Binary Access Write Lock Read As #iFile
      If (Err.Number = 0) Then
         Put #iFile, , sXml
      Else
         ' catch
         MsgBox "Could not open '" & sFile & "' for writing.", vbExclamation
      End If
      ' finally
      Close #iFile
   End If
End Sub

Private Sub cmdDelete_Click()
Dim lPtr As Long
Dim lPtrCurrent As Long
Dim lI As Long
Dim cTLI As cTypeLibInfo
Dim bAlso As Boolean
Dim sPath As String
Dim lOrigIndex As Long

   If lstTypeLibs.ListIndex > 0 Then
      lOrigIndex = lstTypeLibs.ListIndex
      lstTypeLibs_Click
      lPtrCurrent = lstTypeLibs.ItemData(lstTypeLibs.ListIndex)
      If Not lPtrCurrent = 0 Then
         If txtInfo(3).ForeColor = &HC0& Then
            ' typelib not on system, just delete the entry:
            pDeleteEntry lPtrCurrent
         Else
            ' check the same file is not being used elsewhere.
            ' if it is, delete the offending entry & then re-register the
            ' typelib, otherwise just unregister the existing type lib:
            sPath = UCase$(txtInfo(3).Text)
            For lI = 0 To lstTypeLibs.ListCount - 1
               lPtr = lstTypeLibs.ItemData(lI)
               If Not (lPtr = lPtrCurrent) Then
                  If Not lPtr = 0 Then
                     Set cTLI = ObjectFromPtr(lPtr)
                     If StrComp(UCase$(cTLI.Path), sPath) = 0 Then
                        bAlso = True
                        Exit For
                     End If
                  End If
               End If
            Next lI
            
            If bAlso Then
               ' Multi use:
               pDeleteEntry lPtrCurrent
               UIRegisterTypeLib txtInfo(3).Text, True, True
            Else
               ' The only use, unregister it:
               UIRegisterTypeLib txtInfo(3).Text, False, True
            End If
         End If
         
         Populate
         
         If lOrigIndex < lstTypeLibs.ListCount Then
            lstTypeLibs.ListIndex = lOrigIndex
         Else
            lstTypeLibs.ListIndex = lstTypeLibs.ListCount
         End If
         
      End If
   End If
End Sub

Private Sub cmdOK_Click()
   Unload Me
End Sub

Private Sub Form_Load()
   Set Me.Icon = m_frmParent.Icon
   Populate
   ReDim lTabPos(0 To 0) As Long
   lTabPos(0) = (lstTypeLibs.width \ Screen.TwipsPerPixelX) - 32
   TabStop lstTypeLibs.hWnd, lTabPos()
   If lstTypeLibs.ListCount > 0 Then
      lstTypeLibs.ListIndex = 0
   End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   pClearList
End Sub

Private Sub Form_Resize()
Dim i As Long
   On Error Resume Next
   lstTypeLibs.width = Me.ScaleWidth - lstTypeLibs.left * 2
   For i = txtInfo.LBound To txtInfo.UBound
      txtInfo(i).width = lstTypeLibs.width
   Next i
End Sub

Private Sub lstTypeLibs_Click()
Dim lI As Long
Dim lPtr As Long
Dim cTLI As cTypeLibInfo
      
   lI = lstTypeLibs.ListIndex
   If lI > -1 Then
      lPtr = lstTypeLibs.ItemData(lI)
      If Not (lPtr = 0) Then
         Set cTLI = ObjectFromPtr(lPtr)
         txtInfo(0).Text = cTLI.Name
         txtInfo(1).Text = cTLI.CLSID
         txtInfo(2).Text = cTLI.Ver
         txtInfo(3).Text = cTLI.Path
         If Not cTLI.Exists Then
            txtInfo(3).ForeColor = &HC0&
         Else
            txtInfo(3).ForeColor = vbWindowText
         End If
      End If
   End If
   
End Sub