RegTypelib by vb6,UnRegTypelib,Reg tlb File,RegisterTypeLib Visual basic6

[xiaoyao]

Dim Version As String, Tlb As String, TlbGuid As String
Tlb = "c:\002olelib1.81.tlb"
TlbGuid = GetTlbGuid(Tlb, Version)
Debug.Print "tlb file=" & Tlb & vbCrLf & TlbGuid & ",version=" & Version

'Debug.Print RegTypelib(Tlb)
Debug.Print UnRegTypelib(Tlb)

Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function StringFromGUID2 Lib "OLE32.DLL" (GUID As GUID, ByVal lpStrGuid As Long, ByVal cbMax As Long) As Long


Private Const CC_STDCALL As Long = 4
Private Type GUID
    data1 As Long
    data2 As Integer
    data3 As Integer
    data4(0 To 7) As Byte
End Type
Public Type TLIBATTR2
    iid As GUID
    lCID As Long
    SYSKIND As Long
    wMajorVerNum As Integer
    wMinorVerNum As Integer
    wLibFlags As Long
End Type

Private Enum eSYSKIND
   SYS_WIN16 = 0&
   SYS_WIN32 = 1&
   SYS_MAC = 2&
End Enum

Declare Function DispCallFuncPtr Lib "oleaut32" Alias "DispCallFunc" ( _
                         ByVal pvInstance As Long, _
                         ByVal oVft As Long, _
                         ByVal cc As Integer, _
                         ByVal vtReturn As Integer, _
                         ByVal cActuals As Long, _
                         ByRef prgvt As Any, _
                         ByRef prgpvarg As Any, _
                         ByRef pvargResult As Variant) As Long

Private Declare Function LoadTypeLib Lib "oleaut32.dll" (pFileName As Byte, ByVal ptr_pptlib As Long) As Long
Private Declare Function RegisterTypeLib Lib "oleaut32.dll" ( _
    ByVal ptlibPtr As Long, 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
   
Public Function RegTypelib(sLib As String, Optional ByVal UnREG As Boolean) As Boolean
    Dim suLib() As Byte, errOK As Long, pLib_Ptr As Long
     suLib = sLib & vbNullChar
     errOK = LoadTypeLib(suLib(0), VarPtr(pLib_Ptr))
   If errOK <> 0 Then Exit Function
   If Not UnREG Then
            errOK = RegisterTypeLib(pLib_Ptr, suLib(0), 0)
   Else
             Dim lpAttr As Long, tAttr As TLIBATTR2
             lpAttr = ITypeLib_GetLibAttr(pLib_Ptr)
                  ' CallCOMInterface& pLib_Ptr, 3+5, lpAttr
             If lpAttr <> 0 Then
                    CopyMemory tAttr, ByVal lpAttr, LenB(tAttr)
                    errOK = UnRegisterTypeLib(tAttr.iid, tAttr.wMajorVerNum, tAttr.wMinorVerNum, tAttr.lCID, tAttr.SYSKIND)
                    ITypeLib_ReleaseTLibAttr pLib_Ptr, lpAttr
                    'CallCOMInterface& pLib_Ptr, 3+10, lpAttr
            End If
    End If
    RegTypelib = errOK = 0
End Function

 Public Function UnRegTypelib(sLib As String) As Boolean
        UnRegTypelib = RegTypelib(sLib, True)
 End Function
  

Public Function GetTlbGuid(sLib As String, Optional Version As String) As String
    Dim suLib() As Byte, errOK As Long, pLib_Ptr As Long
     suLib = sLib & vbNullChar
     errOK = LoadTypeLib(suLib(0), VarPtr(pLib_Ptr))
   If errOK <> 0 Then Exit Function
             Dim lpAttr As Long, tAttr As TLIBATTR2
             lpAttr = ITypeLib_GetLibAttr(pLib_Ptr)
             If lpAttr <> 0 Then
                    CopyMemory tAttr, ByVal lpAttr, LenB(tAttr)
                    Version = tAttr.wMajorVerNum & "." & tAttr.wMinorVerNum
                    ITypeLib_ReleaseTLibAttr pLib_Ptr, lpAttr
                    GetTlbGuid = GUIDtoStr(tAttr.iid)
            End If
End Function


Public Function ITypeLib_GetLibAttr(ByVal ObjPtrA As Long) As Long
    'GetLibAttr
    Dim resultCall  As Long, pReturn     As Variant, Offset As Long
    pReturn = VarPtr(ITypeLib_GetLibAttr)
    Offset = 28       'Method index=3+5-1 ’IUnknown=3 ' '7*4
    resultCall = DispCallFuncPtr(ObjPtrA, Offset, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(pReturn), 0)
    If resultCall Then Err.Raise resultCall
End Function

Public Sub ITypeLib_ReleaseTLibAttr(ByVal ObjPtrA As Long, ByVal LibAttr As Long)
    Dim resultCall  As Long
    'Method Index = 3 + 10 - 1 'IUnknown=3 ' '12*4
    resultCall = DispCallFuncPtr(ObjPtrA, 48&, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(LibAttr)), 0)
    If resultCall Then Err.Raise resultCall
End Sub

Function GUIDtoStr(GUID1 As GUID) As String
    Dim uuid1 As String, ID As Long, c As Long
    c = 48
    uuid1 = String(48, " ")
    StringFromGUID2 GUID1, StrPtr(uuid1), c
    ID = InStr(uuid1, Chr(0))
    If ID > 0 Then uuid1 = Left(uuid1, ID - 1)
    GUIDtoStr = uuid1
End Function