vbAccelerator - Contents of code file: mRegisterTypeLib.bas

Attribute VB_Name = "mRegisterTypeLib"
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Enum eSYSKIND
   SYS_WIN16 = 0&
   SYS_WIN32 = 1&
   SYS_MAC = 2&
End Enum

Private Declare Function LoadTypeLib Lib "oleaut32.dll" ( _
    pFileName As Byte, pptlib As Object) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
    ByVal ptlib As Object, szFullPath As Byte, _
    szHelpFile As Byte) As Long
Private Declare Function UnRegisterTypeLib Lib "oleaut32.dll" ( _
      libID As GUID, _
      ByVal wVerMajor As Integer, _
      ByVal wVerMinor As Integer, _
      ByVal lCID As Long, _
      ByVal tSysKind As eSYSKIND _
   ) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" (lpsz As Byte, pclsid
 As GUID) As Long

Public Function RegTypelib(sLib As String, ByVal bState As Boolean) As Long
Dim suLib() As Byte
Dim errOK As Long
Dim tlb As Object
   If bState Then
      ' Basic automatically translates strings to Unicode Byte arrays
      ' but doesn't null-terminate, so you must do it yourself
      suLib = sLib & vbNullChar
      ' Pass first byte of array
      errOK = LoadTypeLib(suLib(0), tlb)
      If errOK = 0 Then
         errOK = RegisterTypeLib(tlb, suLib(0), 0)
      End If
      RegTypelib = errOK
   Else
      Dim cTLI As TypeLibInfo
      Dim tGUID As GUID, sCLSID As String
      Dim iMajor As Integer, iMinor As Integer
      Dim lCID As Long

      Set cTLI = TLI.TypeLibInfoFromFile(sLib)
      sCLSID = cTLI.GUID
      iMajor = cTLI.MajorVersion
      iMinor = cTLI.MinorVersion
      lCID = cTLI.lCID
      Set cTLI = Nothing
      
      suLib = sCLSID & vbNullChar
      errOK = CLSIDFromString(suLib(0), tGUID)
      If errOK = 0 Then
         errOK = UnRegisterTypeLib(tGUID, iMajor, iMinor, lCID, SYS_WIN32)
         RegTypelib = errOK
      End If
      
   End If
   
End Function
Public Function UIRegisterTypeLib(ByVal sLib As String, ByVal bState As
 Boolean, ByVal bShowMessage As Boolean) As Boolean
Dim errNo As Long
Dim sPre As String

   errNo = RegTypelib(sLib, bState)
   If bShowMessage Then
      If bState Then
         sPre = "Register Type Library "
      Else
         sPre = "Unregister Type Library "
      End If
      If errNo = 0 Then
         MsgBox sPre & sLib & " succeeded.", vbInformation
      Else
         MsgBox sPre & sLib & " failed: the error returned was " & Hex$(errNo),
          vbCritical
      End If
   End If
   UIRegisterTypeLib = (errNo = 0)
End Function

Public Sub Main()
Dim sCommand As String
Dim iPos As Long
Dim iNextPos As Long
Dim i As Long
Dim sArgs() As String
Dim cArg As Long
Dim bSilent As Boolean
Dim bShowForm As Boolean
Dim sFileName As String
Dim bState As Boolean
Dim fTI As frmTypeLib
   
   sCommand = UCase$(Command)
   If Len(sCommand) > 0 Then
      
      ' Parse arguments:
      iPos = InStr(sCommand, "/")
      Do While iPos <> 0
         iNextPos = InStr(iPos + 1, sCommand, " ")
         cArg = cArg + 1
         ReDim Preserve sArgs(1 To cArg) As String
         If (iNextPos <> 0) Then
            sArgs(cArg) = Mid$(sCommand, iPos, iNextPos - iPos)
            iPos = InStr(iNextPos, sCommand, "/")
         Else
            sArgs(cArg) = Mid$(sCommand, iPos)
            iPos = 0
         End If
      Loop
      If cArg = 0 Or (iNextPos <> 0 And iNextPos < Len(sCommand) - 1) Then
         cArg = cArg + 1
         ReDim Preserve sArgs(1 To cArg) As String
         If (cArg = 1) Then
            sArgs(cArg) = sCommand
         Else
            sArgs(cArg) = Mid$(sCommand, iNextPos + 1)
         End If
      End If
      
      ' Check options:
      bState = True
      For i = 1 To cArg
         Select Case sArgs(i)
         Case "/S"
            bSilent = True
         Case "/U"
            bState = False
         Case "/UI"
            bShowForm = True
         Case Else
            If InStr(sArgs(i), "/") = 0 Then
               sFileName = sArgs(i)
            End If
         End Select
      Next i
      ' Do registration:
      If bShowForm Then
         Set fTI = New frmTypeLib
         fTI.Show
         fTI.Filename = sFileName
         fTI.Register bState
      Else
         If Len(sFileName) = 0 Then
            CommandHelp "No Type Library name specified."
         Else
            UIRegisterTypeLib sFileName, bState, Not (bSilent)
         End If
      End If
      
   Else
      Set fTI = New frmTypeLib
      fTI.Show
   End If
   
End Sub
Private Sub CommandHelp(ByVal sTopMsg)
Dim sMsg As String
   sMsg = sTopMsg & vbCrLf & vbCrLf & "Usage: vbregtlb [/u] [/s] [/ui] tlbname"
    & vbCrLf
   sMsg = sMsg & "/u -" & vbTab & "Unregister Type library" & vbCrLf
   sMsg = sMsg & "/s -" & vbTab & "Silent; display no message boxes" & vbCrLf
   sMsg = sMsg & "/ui -" & vbTab & "Show User Interface"
   MsgBox sMsg, vbExclamation
   
End Sub