Code:
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)Code:
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