Metamorphing Machine I rather be this walking metamorphosis
than having that old formed opinion about everything!

Let's build a transpiler! Part 49

This is the forty-ninth post in a series of building a transpiler.
You can find the previous ones here.

How to fake Shared methods in VB6

Shared methods (static in C# lingo) are methods that "belong" to a Class, and not to an instance of a class.

Let's take our PINQ class as an example: It has several methods that are intended to interact with its private data, like From, Contains, etc.
To use them, we first need to create an instance of a PINQ class:

Class Duck
Public Name As String
Public Likes As String
End Class

Dim Huey As New Duck: Huey.Name = "Huey": Huey.Likes = "Leadership"
Dim Dewey As New Duck: Dewey.Name = "Dewey": Dewey.Likes = "Computers"
Dim Louie As New Duck: Louie.Name = "Louie": Louie.Likes = "Sports"

Dim Ducks As New KeyedList
Ducks.Add Huey
Ducks.Add Dewey
Ducks.Add Louie

Dim Duck As Duck
Dim Query As PINQ
Set Query = New PINQ '<- Instantiating

For Each Duck In Query.From(Ducks).Where(Query!Name, [Like], "*y") '<-Using its From and Where methods
Debug.Print Duck.Name & " likes " & Duck.Likes
Next

In our transpiler's previous version, we had code like this:

Set Found = SymTable.Find(Name:=0, Entity:=TInfo.Name)
Set Found = Found.Where(Found!Flags, [And], 1)

We could not chain Find and Where like we chained From and Where in our ducks example for one reason,
we need Found to be set before being able to use its Item method.

' It will not work; we are using Found here -----------------+
' before it being set here -+                                |
'                           |                                |
'   +-----------------------+                                |
'   |                                                        |
'   v                                                        v
Set Found = SymTable.Find(Name:=0, Entity:=TInfo.Name).Where(Found!Flags, [And], 1)

SymTable's Find method returns a PINQ instance, then we call this instance's Where method.
Where returns the same instance, that would set our Found variable.
Except it doesn't happen, because while calling Where we're using Found, that is not set yet. What a mess!

If shared methods were available in VB6, we could turn Item into one.
For convenience, we could turn its From method into a shared one, too:

Public Shared Property Get From(ByVal Value As KeyedList) As PINQ
Dim Result As PINQ

Set Result = New PINQ
Set Result.MyBase = Value '<-We would need to create a Friend Property Set MyBase method
Set From = Result
End Property

Going back to our ducks example, that would allow us to use our new shared methods like this:

Dim Duck As Duck

For Each Duck In PINQ.From(Ducks).Where(PINQ!Name, [Like], "*y")
Debug.Print Duck.Name & " likes " & Duck.Likes
Next

Now you may be confused.

Please, note that we did not instantiate a PINQ variable anywhere to call its From method.
We're calling it directly from the PINQ class.
PINQ's From method, for its turn, returns a PINQ instance, then we're calling Where from this instance.
And inside Where, we're calling PINQ's Item method directly from PINQ class again.
Everything works as it should.

But, alas, VB6 does not support shared methods.
We can fake them, though.

First, we would need a public PINQ variable in a module:

Module Shareds
Public PINQ As New PINQ
End Module

Then, we would need to paste the following line of code inside every instance method (Where, for instance:)

If Me Is Shareds.PINQ Then Err.Raise 5

It will prevent us from using instance methods as they were shared.
Now, inside "shared" methods we would need to paste this line:

If Not Me Is Shareds.PINQ Then Err.Raise 5

Presto!

Fun fact: In C#, it is illegal to call a static method through an instance; you get the error "Member cannot be accessed with an instance reference; qualify it with a type name instead."
In Java, you can call a static method either directly from a class or through an instance.

Back to business

Last time I said I would go back to our transpiler.
From where I stopped, the next logical step would be to start coding the IDispatch interface the same way I did with IUnknown.

IDispatch has four methods: GetIDsOfNames, GetTypeInfo, GetTypeInfoCount, and Invoke.
All of them have to do with reflection.
VB6 has limited reflection / introspection / RTTI capabilities. It has TypeName, TypeOf ... Is, and CallByName, which is a VBfied version of Invoke.

For code to be able to inspect itself, it needs some kind of metadata. Thinking about it I remembered about type libs.
Type libs are files that describe code artifacts, like classes, interfaces, their members, etc.
Once upon a time, I tried to create a type lib compiler. It didn't go well.
But, as they say, the second time is the charm, right? Right?

So, to the Interwebs I went in search of documentation about type lib files' format and... found the same old and outdated document I've found the first time around.
That's just... sigh!

I've read that document countless times. Some parts did not make sense and still do not even now.
Little by little, with a bit of poking here and experimentation there, I was able to come up with something that may be useful.
Give a file path, it reads its type lib information and dumps the data in a .TXT file.
Even though the code below is written in "make-believe" VB, it was run for real and tested with some typelibs I have.
Due to its exploratory nature, I'm not 100% sure it does what needs to be done. For instance, I don't know yet how to list the interfaces a class implements.
But I had some breakthroughs, so, along with the code below, I'm making available the document itself annotated by me: The Unofficial TypeLib Data Format Specification by TheirCorp

Next week, we'll take a step back.

Andrej Biasic
2021-09-01

Public Module MsftTypeLib
Option Explicit

Public Enum SegDescOffsets
sdoTypeInfoTable = 1
sdoImportInfo
sdoImportedFiles
sdoReferencesTable
sdoLibTable
sdoGUIDTable
sdoUnknown01
sdoNameTable
sdoStringTable
sdoTypeDescriptors
sdoArrayDescriptors
sdoCustomData
sdoGUIDOffsets
sdoUnknown02
sdoUnknown03
End Enum

Public Type TypeLibHeader
Magic1 As Long ' Default: &H5446534D ("MSFT")
Magic2 As Long ' Default: &H10002
GUIDOffset As Long
LocaleID1 As Long
LocaleID2 As Long
VarFlags As Long
Version As Long
Flags As Long
TypeInfoCount As Long
HelpStringOffset As Long
HelpStringContext As Long
HelpContext As Long
NameTableCount As Long
NameTableChars As Long
TypeLibNameOffset As Long
HelpFileNameOffset As Long
CustomDataOffset As Long
Reserved1 As Long ' Default: &H20
Reserved2 As Long ' Default: &H80
DispatchPosition As Long
ImportInfoCount As Long
End Type

Public Type TypeLibHeaderPlusFileName
Header As TypeLibHeader
TypeLibFileNameOffset As Long
End Type

Public Type SegDesc
Offset As Long
Length As Long
Reserved1 As Long ' Default: -1
Reserved2 As Long ' Default: &HF
End Type

Public Type TypeInfo
TypeKind As Long
FunctionRecordsOffset As Long
MemoryAllocation As Long
ReconstitutedSize As Long
Reserved1 As Long ' Default: 3
Reserved2 As Long ' Default: 0
FunctionCount As Integer
PropertyCount As Integer
Reserved3 As Long ' Default: 0
Reserved4 As Long ' Default: 0
Reserved5 As Long ' Default: 0
Reserved6 As Long ' Default: 0
GUIDOffset As Long
TypeFlags As Long
NameOffset As Long
Version As Long
DocStringOffset As Long
HelpStringContext As Long
HelpContext As Long
CustomDataOffset As Long
ImplementedInterfaces As Integer
VirtualTableSize As Integer
Unknown3 As Long
DataType1Offset As Long
DataType2 As Long
Reserved7 As Long ' Default: 0
Reserved8 As Long ' Default: -1
End Type

Public Type ImpInfo
Count As Integer
Flags As Byte
TypeKind As Byte
ImportFileOffset As Long
GUIDOffset As Long
End Type

Public Type TlbImpLib
GUIDOffset As Long
LCID As Long
MajVer As Integer 'Unsigned
MinVer As Integer 'Unsigned
SizeTimes4 As Integer 'Unsigned
End Type

Public Type TlbImpLibWithText
TlbImpLib As TlbImpLib
Text As String
End Type

Public Type RefRecord
RefType As Long
Flags As Long
CustDataOffset As Long
NextOffset As Long
End Type

Public Type GUIDEntry
GUID(0 To 15) As Byte
hRefType As Long
NextHash As Long
End Type

Public Type TlbName
hRefType As Long
NextHash As Long
NameLength As Byte
Flags As Byte
HashCode As Integer 'Unsigned
End Type

Public Type TlbNameText
TlbName As TlbName
Text As String
Offset As Long
End Type

Public Type TlbString
Length As Integer 'Unsigned
Text As String
End Type

Public Type TypeDescriptor
Value1 As Integer
Value2 As Integer
Value3 As Integer
Value4 As Integer
End Type

Public Type SafeArrayBound
cElements As Long
iLBound As Long
End Type

Public Type ArrayDesc
TypeDescriptor As Long 'Unsigned
Dimensions As Integer 'Unsigned
DataType As Integer 'Unsigned
Bounds() As SafeArrayBound
End Type

Public Type ParamInfo
DataType As Integer
Flags As Integer
NameOffset As Long
ParamFlags As Long
End Type

Public Type FuncRecord
RecordSize As Integer 'Unsigned
Unknown1 As Integer 'Unsigned
DataType As Integer
Flags As Integer
Reserved1 As Long
#If BigEndian Then
FuncDescSize As Integer
VirtualTableOffset As Integer
#Else
VirtualTableOffset As Integer
FuncDescSize As Integer
#End If
FKCCIC As Long
ParameterCount As Integer
Unknown2 As Integer
HelpContext As Long
HelpString As Long
Entry As Long
Reserved2 As Long
Reserved3 As Long
HelpStringContext As Long
CustomDataOffset As Long
CustomDataForArgsOffset() As Long
ParameterInfo() As ParamInfo
End Type

Public Type PropRecord
RecordSize As Integer 'Unsigned
PropNum As Integer 'Unsigned
DataType As Integer
Flags As Integer
#If BigEndian Then
VarDescSize As Integer
VarKind As Integer
#Else
VarKind As Integer
VarDescSize As Integer
#End If
OffsValue As Long
Unknown As Long
HelpContext As Long
HelpString As Long
Reserved As Long ' Default: -1
CustomDataOffset As Long
HelpStringContext As Long
End Type

Public Type ArrayGroup
FuncRecordArraySize As Long
FunctionRecord() As FuncRecord
PropertyRecord() As PropRecord
MethodOrPropertyID() As Long 'Unsigned
NameOffsets() As Long 'Unsigned
OffsetsToRecords() As Long 'Unsigned
End Type

Public Type TypeLibData
TypeLibHeader As TypeLibHeaderPlusFileName
TypeInfosOffsets() As Long
SegmentDirectory(1 To 15) As SegDesc
TypeInfoTable() As TypeInfo
ImportInfoTable() As ImpInfo
ImportedTypeLibTable() As TlbImpLibWithText
ReferencesTable() As RefRecord
LibTable(1 To 32) As Long
GUIDTable() As GUIDEntry
Unknown1(1 To 128) As Long
NameTable() As TlbNameText
StringTable() As TlbString
TypeDescriptors() As TypeDescriptor
ArrayDescriptors() As ArrayDesc
CustomData() As Long
GUIDOffsets() As Long
FuncAndPropRecords() As ArrayGroup
End Type

Public ImpInfo As ImpInfo
Public TypeInfo As TypeInfo
Public TlbImpLib As TlbImpLib
Public RefRecord As RefRecord
Public GUIDEntry As GUIDEntry
Public ArrayDesc As ArrayDesc
Public ParamInfo As ParamInfo
Public TypeDescriptor As TypeDescriptor

Public Sub PrintTypeLib(ByVal Path As String)
Const Len_Integer = 2
Const Len_Long = 4
Const VT_PTR = 26
Const VT_SAFE_ARRAY = 27
Const VT_CARRAY = 28
Const VT_UDT = 29

Static Reg As New Register

Dim Handle As Integer
Dim Idx As Long
Dim Jdx As Long
Dim Kdx As Long
Dim Ldx As Long
Dim Mdx As Long
Dim Count As Long
Dim PrpDescIdx As Long
Dim ArrDescIdx As Long
Dim Tmp As Long
Dim G As String
Dim ThisGuid As String
Dim ThatGuid As String
Dim Key As String
Dim OutFile As String
Dim TypeKinds() As String
Dim FuncKinds() As String
Dim InvKinds() As String
Dim CallConvs() As String
Dim IInfo As ImpInfo
Dim TInfo As TypeInfo
Dim ImpFile As TlbImpLib
Dim PInfo As ParamInfo
Dim ADesc As ArrayDesc
Dim FPRec As ArrayGroup
Dim FRec As FuncRecord
Dim PRec As PropRecord
Dim TLib As TypeLibData
Dim Data As TypeLibData
Dim TDesc As TypeDescriptor
Dim Cache As New Dictionary
Dim ImpFileTxt As TlbImpLibWithText

TypeKinds = Split("Enum,Record,Module,Interface,Dispatch,Coclass,Alias,Union", Delimiter:=",")
FuncKinds = Split("Virtual,PureVirtual,NonVirtual,Static,Dispatch", Delimiter:=",")
InvKinds = Split("Sub/Function,Property Get,Property Let,,Property Set", Delimiter:=",")
CallConvs = Split("FASTCALL,CDECL,PASCAL,MACPASCAL,STDCALL,FPFASTCALL,SYSCALL,MPWCDECL,MPWPASCAL", Delimiter:=",")

Handle = FreeFile
Open Path & ".txt" For Output Access Write As #Handle
Print #Handle, "Path: " & Path

TLib = ParseTLib(Path)

If TLib.TypeLibHeader.Header.VarFlags And &H100 Then 'Has file name
Print #Handle, "File name : ";
Print #Handle, GetString(TLib, TLib.TypeLibHeader.TypeLibFileNameOffset)
End If

If TLib.TypeLibHeader.Header.HelpStringOffset <> -1 Then _
Print #Handle, "Help string: " & GetString(TLib, TLib.TypeLibHeader.Header.HelpStringOffset)

Print #Handle, "Help file ? " & IIf(TLib.TypeLibHeader.Header.VarFlags And &H20, "True", "False")
Print #Handle,

Print #Handle, "*********************"
Print #Handle, "* Import type table *"
Print #Handle, "*********************"

For Idx = 1 To UBound(TLib.ImportInfoTable)
IInfo = TLib.ImportInfoTable(Idx)
Print #Handle, "Index : " & IInfo.Count

If IInfo.Flags And 1 Then
Print #Handle, "GUID : " & GetGuid(TLib.GUIDTable, IInfo.GUIDOffset)
Else
Print #Handle, "TypeInfo index : " & IInfo.GUIDOffset
End If

Print #Handle, "Offset into table below: " & IInfo.ImportFileOffset
Print #Handle, "TypeKind : " & TypeKinds(IInfo.TypeKind)
Print #Handle,
Next

Print #Handle, "*********************"
Print #Handle, "* Import file table *"
Print #Handle, "*********************"

For Idx = 1 To UBound(TLib.ImportedTypeLibTable)
ImpFileTxt = TLib.ImportedTypeLibTable(Idx)
Print #Handle, "File : " & ImpFileTxt.Text
Print #Handle, "Offset : " & Count
Print #Handle, "LCID : &H" & Hex$(ImpFileTxt.TlbImpLib.LCID)
Print #Handle, "Version: " & ImpFileTxt.TlbImpLib.MajVer & "." & ImpFileTxt.TlbImpLib.MinVer
Print #Handle,

Count += 14 + Len(ImpFileTxt.Text) + _
IIf(Len(ImpFileTxt.Text) Mod 14, (Len(ImpFileTxt.Text) \ 14 + 1) * 14 - Len(ImpFileTxt.Text), 0)
Next

Print #Handle, "*******************"
Print #Handle, "* Reference table *"
Print #Handle, "*******************"

For Idx = 1 To UBound(TLib.ReferencesTable)
If TLib.ReferencesTable(Idx).RefType And 3 Then
Print #Handle, "Offset to external reference table: ";
Else
Print #Handle, "Offset to Type Info table : ";
End If

Print #Handle, CStr(TLib.ReferencesTable(Idx).RefType)
Next

Print #Handle,

Print #Handle, "**************"
Print #Handle, "* Type infos *"
Print #Handle, "**************"

For Idx = 1 To UBound(TLib.TypeInfoTable)
TInfo = TLib.TypeInfoTable(Idx)

Print #Handle, "Element : " & GetName(TLib.NameTable, TInfo.NameOffset)
If TInfo.TypeFlags Then Print #Handle, "TypeFlags : " & Flags(TInfo.TypeFlags)
Print #Handle, "TypeKind : " & TypeKinds(TInfo.TypeKind And &HF)
If TInfo.GUIDOffset <> -1 Then Print #Handle, "GUID : " & GetGuid(TLib.GUIDTable, TInfo.GUIDOffset)

Select Case TInfo.TypeKind And &HF
Case 3 To 5 'Interface, Dispatch, CoClass
Print #Handle, "Impl. int.: " & TInfo.ImplementedInterfaces
Print #Handle, "Version : " & TInfo.Version
End Select

Select Case TInfo.TypeKind And &HF
Case 6 'Alias
Print #Handle, "Target : ";

If TInfo.DataType1Offset < 0 Then
Print #Handle, GetDataType(TInfo.DataType1Offset And &HFF)
Else
Tmp = TInfo.DataType1Offset \ Len(TypeDescriptor) + 1
Tmp = TLib.TypeDescriptors(Tmp).Value4 << 16 Or TLib.TypeDescriptors(Tmp).Value3
Tmp = Tmp \ Len(TypeInfo) + 1
Print #Handle, GetName(TLib.NameTable, TLib.TypeInfoTable(Tmp).NameOffset)
End If

Case 5 'CoClass
Rem DataType1 is an offset into RefTable
Tmp = TInfo.DataType1Offset \ Len(RefRecord) + 1
Tmp = TLib.ReferencesTable(Tmp).RefType \ Len(TypeInfo) + 1
Print #Handle, "Ref. to : " & GetName(TLib.NameTable, TLib.TypeInfoTable(Tmp).NameOffset)

Case 3 'Interface
Rem DataType1 is a reference to inherited interface
If TInfo.DataType1Offset <> -1 Then
Tmp = TInfo.DataType1Offset \ Len(TypeInfo) + 1
Print #Handle, "Inherits : " & GetName(TLib.NameTable, TLib.TypeInfoTable(Tmp).NameOffset)
End If
End Select

If TInfo.FunctionCount + TInfo.PropertyCount Then
PrpDescIdx += 1
FPRec = TLib.FuncAndPropRecords(PrpDescIdx)

For Kdx = 1 To TInfo.FunctionCount
FRec = FPRec.FunctionRecord(Kdx)
Print #Handle, " Method : ";
Print #Handle, GetName(TLib.NameTable, FPRec.NameOffsets(Kdx))

Print #Handle, " Data type : " & GetDataType(FRec.DataType)
Print #Handle, " Function Kind : " & FuncKinds(FRec.FKCCIC And 7)
Print #Handle, " Invocation Kind : " & InvKinds((FRec.FKCCIC And &H70) >> 4)
Print #Handle, " Has custom data ? " & IIf(FRec.FKCCIC And &H80, "True", "False")
Print #Handle, " Calling convention: " & CallConvs((FRec.FKCCIC And &HF00) >> 8)
Print #Handle, " Has default value ? " & IIf(FRec.FKCCIC And &H1000, "True", "False")
Print #Handle, " DispID : " & FPRec.MethodOrPropertyID(Kdx)

If FRec.HelpString And UBound(TLib.StringTable) Then
Print #Handle, " Help string : " & GetString(TLib, FRec.HelpString)
End If

If FRec.ParameterCount Then Print #Handle, " Parameters :"

For Ldx = 1 To FRec.ParameterCount
PInfo = FRec.ParameterInfo(Ldx)
Print #Handle, " Position : " & Ldx
Print #Handle, " Name : " & GetName(TLib.NameTable, PInfo.NameOffset)
Print #Handle, " Data type : ";

Do
If PInfo.Flags Then
Print #Handle, GetDataType(PInfo.DataType)
Exit Do
End If

Count = PInfo.DataType \ Len(TypeDesc) + 1

Do
TDesc = TLib.TypeDescriptors(Count)
If TDesc.Value1 <> VT_PTR And TDesc.Value1 <> VT_SAFE_ARRAY Or TDesc.Value4 < 0 Then Exit Do

Count = CLng(TDesc.Value4) << 16 Or TDesc.Value3
Count = Count \ Len(TypeDesc) + 1
Loop

Select Case TDesc.Value1
Case VT_PTR, VT_SAFE_ARRAY
Print #Handle, GetDataType(TDesc.Value3)

Case VT_CARRAY
Print #Handle, GetDataType(TLib.ArrayDescriptors(Count).TypeDescriptor And &HFFFF&)
Print #Handle, "Array bounds:";

For Mdx = 1 To TLib.ArrayDescriptors(Count).Dimensions
Print #Handle, TLib.ArrayDescriptors(Count).Bounds(Mdx).iLBound;
Print #Handle, " To ";
Print #Handle, TLib.ArrayDescriptors(Count).Bounds(Mdx).cElements + _
TLib.ArrayDescriptors(Count).Bounds(Mdx).iLBound;
Next Mdx

Case VT_UDT
Count = CLng(TDesc.Value4) << 16 Or TDesc.Value3
Count = Count \ Len(TypeInfo) + 1

If (TDesc.Value3 And 1) = 0 Then
Print #Handle, GetName(TLib.NameTable, TLib.TypeInfoTable(Count).NameOffset)
Exit Do
End If

Count = CLng(TDesc.Value4) << 16 Or TDesc.Value3
Count = Count \ Len(ImpInfo) + 1
IInfo = TLib.ImportInfoTable(Count)

ImpFile = TLib.ImportedTypeLibTable(IInfo.ImportFileOffset + 1).TlbImpLib
G = GetGuid(TLib.GUIDTable, IInfo.GUIDOffset)

If Not Cache.Exists(G) Then
Rem Get imported file GUID
Key = GetGuid(TLib.GUIDTable, ImpFile.GUIDOffset)
Rem Build registry path
Key = "SOFTWARE\Classes\TypeLib\" & Key & "\" & _
ImpFile.MajVer & "." & ImpFile.MinVer & "\" & ImpFile.LCID
#If Win64 Then
Key &= "\win64"
#Else
Key &= "\win32"
#End If
Rem Get file's path
Key = Reg.ReadReg(LocalMachine, Key)
Rem Parse .TLB file.
Data = ParseTLib(Key)
Rem Get element's GUID

For Mdx = 1 To UBound(Data.GUIDTable)
Tmp = TLib.ImportInfoTable(Count).GUIDOffset \ Len(GUIDEntry) + 1
ThisGuid = TLib.GUIDTable(Tmp).GUID
ThatGuid = Data.GUIDTable(Mdx).GUID

If ThisGuid = ThatGuid Then
Tmp = Data.GUIDTable(Mdx).hRefType \ Len(TypeInfo) + 1
Key = GetName(Data.NameTable, Data.TypeInfoTable(Tmp).NameOffset)
Cache.Add G, Key
Exit For
End If
Next Mdx
End If

Print #Handle, Cache(G)
End Select
Loop While False

Print #Handle, " Param flags : " & ParFlags(PInfo.ParamFlags)

If (PInfo.ParamFlags And &H20) <> 0 And LBound(FRec.CustomDataForArgsOffset) Then
Print #Handle, " Default Value : ";

If FRec.CustomDataForArgsOffset(Ldx) < 0 Then
Rem TODO: Convert to proper data type
Print #Handle, CStr(FRec.CustomDataForArgsOffset(Ldx) And &HFFFFFF)
Else
PrintCustomString Handle, TLib, FRec.CustomDataForArgsOffset(Ldx) \ 4 + 1
End If
End If

Print #Handle,
Count += Len(ParamInfo)
Next Ldx

If FRec.ParameterCount = 0 Then Print #Handle,
Next Kdx

For Kdx = 1 To TInfo.PropertyCount
PRec = FPRec.PropertyRecord(Kdx)
Print #Handle, " Name : " & GetName(TLib.NameTable, FPRec.NameOffsets(TInfo.FunctionCount + Kdx))

If PRec.OffsValue And 8 Then
Rem &H380000: Fixed-size array.
Rem &H2C0000: Variable-size array or a pointer.
Rem It seems we should get to its Array Descriptor by reading order.
Rem According to my observations, no two Array Descriptors are ever shared.
ArrDescIdx += 1

If ArrDescIdx > UBound(TLib.ArrayDescriptors) Then
Print #Handle, " Data type : ";
Print #Handle, GetDataType(TLib.TypeDescriptors(PRec.DataType \ Len(TypeDescriptor) + 1).Value3)
Else
ADesc = TLib.ArrayDescriptors(ArrDescIdx)
Print #Handle, " Data type : " & GetDataType(ADesc.TypeDescriptor And &HFFFF&) & "(";

For Ldx = 1 To ADesc.Dimensions
Print #Handle, CStr(ADesc.Bounds(Ldx).iLBound);
Print #Handle, " To ";
Print #Handle, CStr(ADesc.Bounds(Ldx).cElements + ADesc.Bounds(Ldx).iLBound - 1);
If Ldx <> ADesc.Dimensions Then Print #Handle, ", "
Next

Print #Handle, ")"
End If
Else
Print #Handle, " Data type : " & GetDataType(PRec.DataType)
End If

If PRec.Unknown < 0 Then
Print #Handle, " Value : " & CStr(PRec.Unknown And &HFFFFFF)

ElseIf (TInfo.TypeKind And &HF) = 1 Then
Print #Handle, " Position : " & PRec.Unknown
End If

Print #Handle,

Next
End If

If TInfo.FunctionCount + TInfo.PropertyCount = 0 Then Print #Handle,
Next Idx

Close #Handle
End Sub

Public Function ParseTLib(ByVal Path As String) As TypeLibData
Dim Handle As Integer
Dim Off As Long
Dim Idx As Long
Dim Jdx As Long
Dim Kdx As Long
Dim Count As Long
Dim Total As Long
Dim Length As Long
Dim Adjust As Long

On Error GoTo ErrHandler
If Dir(Path) = "" Then Err.Raise 53
Handle = FreeFile
Open Path For Binary Access Read As #Handle

With ParseTLib
Get #Handle, , .TypeLibHeader.Header

If .TypeLibHeader.Header.Magic1 <> &H5446534D Then
If (.TypeLibHeader.Header.Magic1 And &HFFFF&) <> &H5A4D Then Err.Raise vbObjectError + 14, , "File format not supported"
Length = LOF(Handle) - Len(.TypeLibHeader.Header)
Adjust = 80

Do
Get #Handle, , Total
Length = Length - 4
Adjust = Adjust + 4
Loop Until Total = &H5446534D Or Length = 0

If Length = 0 Then Err.Raise vbObjectError + 15, , "File does not contain a TypeLib resource"
Length = 0
Seek #Handle, Seek(Handle) - 4
Get #Handle, , .TypeLibHeader.Header
End If

If (.TypeLibHeader.Header.VarFlags And &H100) <> 0 Then
Get #Handle, , .TypeLibHeader.TypeLibFileNameOffset
Else
.TypeLibHeader.TypeLibFileNameOffset = -1
End If

ReDim .TypeInfosOffsets(1 To .TypeLibHeader.Header.TypeInfoCount)

For Idx = 1 To .TypeLibHeader.Header.TypeInfoCount
Get #Handle, , .TypeInfosOffsets(Idx)
Next

Get #Handle, , .SegmentDirectory

Count = .TypeLibHeader.Header.TypeInfoCount
ReDim .TypeInfoTable(1 To Count)

For Idx = 1 To Count
Get #Handle, , .TypeInfoTable(Idx)
Next

If .SegmentDirectory(sdoImportInfo).Length = 0 Then
ReDim .ImportInfoTable(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoImportInfo).Offset + Adjust + 1
Count = .TypeLibHeader.Header.ImportInfoCount
ReDim .ImportInfoTable(1 To Count)

For Idx = 1 To Count
Get #Handle, , .ImportInfoTable(Idx)
Next
End If

If .SegmentDirectory(sdoImportedFiles).Length = 0 Then
ReDim .ImportedTypeLibTable(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoImportedFiles).Offset + Adjust + 1
Length = .SegmentDirectory(sdoImportedFiles).Length
Idx = 0

Do While Length > 0
Idx += 1
Length -= Len(TlbImpLib)
ReDim Preserve .ImportedTypeLibTable(1 To Idx)
Get #Handle, , .ImportedTypeLibTable(Idx).TlbImpLib
Count = .ImportedTypeLibTable(Idx).TlbImpLib.SizeTimes4 >> 2

If Count Then
.ImportedTypeLibTable(Idx).Text = Space$(Count)
Get #Handle, , .ImportedTypeLibTable(Idx).Text
Length -= Count
Count = (Count \ 14 + 1) * 14 - Count

If Count Then
Length = Length - Count
Seek #Handle, Seek(Handle) + Count
End If
End If
Loop
End If

Count = .SegmentDirectory(sdoReferencesTable).Length \ Len(RefRecord)

If Count = 0 Then
ReDim .ReferencesTable(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoReferencesTable).Offset + Adjust + 1
ReDim .ReferencesTable(1 To Count)

For Idx = 1 To Count
Get #Handle, , .ReferencesTable(Idx)
Next
End If

Seek #Handle, .SegmentDirectory(sdoLibTable).Offset + Adjust + 1
Get #Handle, , .LibTable

Seek #Handle, .SegmentDirectory(sdoGUIDTable).Offset + Adjust + 1
Count = .SegmentDirectory(sdoGUIDTable).Length \ Len(GUIDEntry)
ReDim .GUIDTable(1 To Count)

For Idx = 1 To Count
Get #Handle, , .GUIDTable(Idx)
Next

Get #Handle, , .Unknown1

Seek #Handle, .SegmentDirectory(sdoNameTable).Offset + Adjust + 1
Count = .TypeLibHeader.Header.NameTableCount
ReDim .NameTable(1 To Count)

For Idx = 1 To Count
With .NameTable(Idx).TlbName
Get #Handle, , .hRefType '4 bytes
Get #Handle, , .NextHash '4 bytes
Get #Handle, , .NameLength '1 byte
Get #Handle, , .Flags '1 byte
Get #Handle, , .HashCode '2 bytes
Length = .NameLength
End With

.NameTable(Idx).Text = String$(Length, " ")
Get #Handle, , .NameTable(Idx).Text

.NameTable(Idx).Offset = Off
Off += .NameTable(Idx).TlbName.NameLength + 12

If Length And 3 Then
Length = (Length + 3 And -4) - Length 'Calculate how many bytes are needed to round to next multiple of 4
Seek #Handle, Seek(Handle) + Length
Off += Length
End If
Next

If .SegmentDirectory(sdoStringTable).Length = 0 Then
ReDim Preserve .StringTable(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoStringTable).Offset + Adjust + 1
Count = .SegmentDirectory(sdoStringTable).Length
Idx = 0

Do
Idx += 1
ReDim Preserve .StringTable(1 To Idx)
Get #Handle, , .StringTable(Idx).Length
Length = .StringTable(Idx).Length
.StringTable(Idx).Text = String$(Length, " ")
Get #Handle, , .StringTable(Idx).Text
Length += Len_Integer

If Length And 3 Then
Length = (Length + 3 And -4) - Length 'Calculate how many bytes are needed to round to next multiple of 4
Seek #Handle, Seek(Handle) + Length
Else
Length = 0
End If

Count -= .StringTable(Idx).Length + Length + Len_Integer
Loop While Count > 0
End If

If .SegmentDirectory(sdoTypeDescriptors).Length = 0 Then
ReDim .TypeDescriptors(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoTypeDescriptors).Offset + Adjust + 1
Count = .SegmentDirectory(sdoTypeDescriptors).Length >> 3
ReDim .TypeDescriptors(1 To Count)

For Idx = 1 To Count
Get #Handle, , .TypeDescriptors(Idx)
Next
End If

If .SegmentDirectory(sdoArrayDescriptors).Length = 0 Then
ReDim .ArrayDescriptors(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoArrayDescriptors).Offset + Adjust + 1
Count = .SegmentDirectory(sdoArrayDescriptors).Length \ Len(ArrayDesc)
ReDim .ArrayDescriptors(1 To Count)

For Idx = 1 To Count
Get #Handle, , .ArrayDescriptors(Idx).TypeDescriptor
Get #Handle, , .ArrayDescriptors(Idx).Dimensions
Get #Handle, , .ArrayDescriptors(Idx).DataType

If .ArrayDescriptors(Idx).Dimensions > 0 Then
ReDim .ArrayDescriptors(Idx).Bounds(1 To .ArrayDescriptors(Idx).Dimensions)

For Jdx = 1 To .ArrayDescriptors(Idx).Dimensions
Get #Handle, , .ArrayDescriptors(Idx).Bounds(Jdx)
Next
Else
ReDim .ArrayDescriptors(Idx).Bounds(0 To 0)
End If
Next
End If

If .SegmentDirectory(sdoCustomData).Length = 0 Then
ReDim .CustomData(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoCustomData).Offset + Adjust + 1
Count = .SegmentDirectory(sdoCustomData).Length >> 2
ReDim .CustomData(1 To Count)

For Idx = 1 To Count
Get #Handle, , .CustomData(Idx)
Next
End If

If .SegmentDirectory(sdoGUIDOffsets).Length = 0 Then
ReDim .GUIDOffsets(0 To 0)
Else
Seek #Handle, .SegmentDirectory(sdoGUIDOffsets).Offset + Adjust + 1
Count = .SegmentDirectory(sdoGUIDOffsets).Length
ReDim .GUIDOffsets(1 To Count)

For Idx = 1 To Count
Get #Handle, , .GUIDOffsets(Idx)
Next
End If

Count = 0

For Jdx = 1 To UBound(.TypeInfoTable)
Seek #Handle, .TypeInfoTable(Jdx).FunctionRecordsOffset + Adjust + 1
Total = .TypeInfoTable(Jdx).FunctionCount + .TypeInfoTable(Jdx).PropertyCount
Length = 0

If Total Then
Count += 1
ReDim Preserve .FuncAndPropRecords(1 To Count)

With ParseTLib.FuncAndPropRecords(Count)
Get #Handle, , .FuncRecordArraySize

If ParseTLib.TypeInfoTable(Jdx).FunctionCount = 0 Then
ReDim .FunctionRecord(0 To 0)
Else
ReDim .FunctionRecord(1 To ParseTLib.TypeInfoTable(Jdx).FunctionCount)

For Idx = 1 To ParseTLib.TypeInfoTable(Jdx).FunctionCount
With .FunctionRecord(Idx)
ReDim .CustomDataForArgsOffset(0 To 0) 'In case there's no custom data below
Get #Handle, , .RecordSize '2 bytes
Get #Handle, , .Unknown1 '2 bytes
Get #Handle, , .DataType '2 bytes
Get #Handle, , .Flags '2 bytes
Get #Handle, , .Reserved1 '4 bytes
Get #Handle, , .VirtualTableOffset '2 bytes
Get #Handle, , .FuncDescSize '2 bytes
Get #Handle, , .FKCCIC '4 bytes
Get #Handle, , .ParameterCount '2 bytes
Get #Handle, , .Unknown2 '2 bytes

Length = .RecordSize - 24 - .ParameterCount * Len(ParamInfo)
If .FKCCIC And &H1000 Then Length = Length - .ParameterCount * Len_Long

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length -= Len_Long
Get #Handle, , .HelpContext

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .HelpString

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .Entry

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .Reserved2

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .Reserved3

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .HelpStringContext

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Continue For
Length = Length - Len_Long
Get #Handle, , .CustomDataOffset

If Length = 0 Then If .ParameterCount Then GoTo Parms Else Continue For
Data:
ReDim .CustomDataForArgsOffset(1 To .ParameterCount)

For Kdx = 1 To .ParameterCount
Get #Handle, , .CustomDataForArgsOffset(Kdx)
Next

Parms:
ReDim .ParameterInfo(1 To .ParameterCount)

For Kdx = 1 To .ParameterCount
Get #Handle, , .ParameterInfo(Kdx)
Next
End With
Next
End If

If ParseTLib.TypeInfoTable(Jdx).PropertyCount = 0 Then
ReDim .PropertyRecord(0 To 0)
Else
ReDim .PropertyRecord(1 To ParseTLib.TypeInfoTable(Jdx).PropertyCount)

For Idx = 1 To ParseTLib.TypeInfoTable(Jdx).PropertyCount
With .PropertyRecord(Idx)
Get #Handle, , .RecordSize '2 bytes
Get #Handle, , .PropNum '2 bytes
Get #Handle, , .DataType '2 bytes
Get #Handle, , .Flags '2 bytes
Get #Handle, , .VarKind '2 bytes
Get #Handle, , .VarDescSize '2 bytes
Get #Handle, , .OffsValue '4 bytes

Length = .RecordSize - 16

If Length = 0 Then Continue For
Get #Handle, , .Unknown
Length -= Len_Long

If Length = 0 Then Continue For
Get #Handle, , .HelpContext
Length -= Len_Long

If Length = 0 Then Continue For
Get #Handle, , .HelpString
Length -= Len_Long

If Length = 0 Then Continue For
Get #Handle, , .Reserved
Length -= Len_Long

If Length = 0 Then Continue For
Get #Handle, , .CustomDataOffset
Length -= Len_Long

If Length = 0 Then Continue For
Get #Handle, , .HelpStringContext
Length -= Len_Long
End With
Next
End If

Length = 0
ReDim .MethodOrPropertyID(1 To Total)
ReDim .NameOffsets(1 To Total)
ReDim .OffsetsToRecords(1 To Total)

For Idx = 1 To Total
Get #Handle, , .MethodOrPropertyID(Idx)
Next

For Idx = 1 To Total
Get #Handle, , .NameOffsets(Idx)
Next

For Idx = 1 To Total
Get #Handle, , .OffsetsToRecords(Idx)
Next
End With
End If
Next Jdx

If Count = 0 Then ReDim .FuncAndPropRecords(0 To 0)
End With

ErrHandler:
Close #Handle
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function

Private Function GetName(ByRef Names() As TlbNameText, ByVal Off As Long) As String
Dim Idx As Long

For Idx = 1 To UBound(Names)
Select Case Names(Idx).Offset
Case Off
Exit Names(Idx).Text

Case Is > Off
Exit For
End Select
Next

Exit "rhs"
End Function

Private Function GetGuid(ByRef Guids() As GUIDEntry, ByVal Off As Long) As String
Dim Result As String
Dim G As GUIDEntry

Off = Off \ Len(GUIDEntry) + 1
G = Guids(Off)
Result = Format$(Hex$(G.GUID(3)), "{@@")
Result &= Format$(Hex$(G.GUID(2)), "@@")
Result &= Format$(Hex$(G.GUID(1)), "@@")
Result &= Format$(Hex$(G.GUID(0)), "@@")
Result &= "-"
Result &= Format$(Hex$(G.GUID(5)), "@@")
Result &= Format$(Hex$(G.GUID(4)), "@@")
Result &= "-"
Result &= Format$(Hex$(G.GUID(7)), "@@")
Result &= Format$(Hex$(G.GUID(6)), "@@")
Result &= "-"
Result &= Format$(Hex$(G.GUID(8)), "@@")
Result &= Format$(Hex$(G.GUID(9)), "@@")
Result &= "-"
Result &= Format$(Hex$(G.GUID(10)), "@@")
Result &= Format$(Hex$(G.GUID(11)), "@@")
Result &= Format$(Hex$(G.GUID(12)), "@@")
Result &= Format$(Hex$(G.GUID(13)), "@@")
Result &= Format$(Hex$(G.GUID(14)), "@@")
Result &= Format$(Hex$(G.GUID(15)), "@@}")
Exit Replace$(Result, " ", "0")
End Function

Private Function GetString(ByRef TLib As TypeLibData, ByVal Off As Long) As String
Dim Count As Long
Dim Idx As Long
Dim Length As Long

For Idx = 1 To UBound(TLib.StringTable)
If Count = Off Then Exit TLib.StringTable(Idx).Text

Length = TLib.StringTable(Idx).Length + Len_Integer
Count += Length
If Length And 3 Then Count += (Length + 3 And -4) - Length
Next
End Function

Private Function Flags(ByVal Value As Long) As String
Const TYPEFLAG_FAPPOBJECT = &H1
Const TYPEFLAG_FCANCREATE = &H2
Const TYPEFLAG_FLICENSED = &H4
Const TYPEFLAG_FPREDECLID = &H8
Const TYPEFLAG_FHIDDEN = &H10
Const TYPEFLAG_FCONTROL = &H20
Const TYPEFLAG_FDUAL = &H40
Const TYPEFLAG_FNONEXTENSIBLE = &H80
Const TYPEFLAG_FOLEAUTOMATION = &H100
Const TYPEFLAG_FRESTRICTED = &H200
Const TYPEFLAG_FAGGREGATABLE = &H400
Const TYPEFLAG_FREPLACEABLE = &H800
Const TYPEFLAG_FDISPATCHABLE = &H1000
Const TYPEFLAG_FREVERSEBIND = &H2000

Dim Result As String

If TYPEFLAG_FAPPOBJECT And Value Then Result = "APPOBJECT"
If TYPEFLAG_FCANCREATE And Value Then Result &= " CANCREATE"
If TYPEFLAG_FLICENSED And Value Then Result &= " LICENSED"
If TYPEFLAG_FPREDECLID And Value Then Result &= " PREDECLID"
If TYPEFLAG_FHIDDEN And Value Then Result &= " HIDDEN"
If TYPEFLAG_FCONTROL And Value Then Result &= " CONTROL"
If TYPEFLAG_FDUAL And Value Then Result &= " DUAL"
If TYPEFLAG_FNONEXTENSIBLE And Value Then Result &= " NONEXTENSIBLE"
If TYPEFLAG_FOLEAUTOMATION And Value Then Result &= " OLEAUTOMATION"
If TYPEFLAG_FRESTRICTED And Value Then Result &= " RESTRICTED"
If TYPEFLAG_FAGGREGATABLE And Value Then Result &= " AGGREGATABLE"
If TYPEFLAG_FREPLACEABLE And Value Then Result &= " REPLACEABLE"
If TYPEFLAG_FDISPATCHABLE And Value Then Result &= " DISPATCHABLE"
If TYPEFLAG_FREVERSEBIND And Value Then Result &= " REVERSEBIND"
Exit Replace$(Trim$(Result), " ", ", ")
End Function

Private Function GetDataType(ByVal Value As Long) As String
Select Case Value
Case vbEmpty
Exit "Empty"

Case vbNull
Exit "Null"

Case vbInteger
Exit "Integer"

Case vbLong
Exit "Long"

Case vbSingle
Exit "Single"

Case vbDouble
Exit "Double"

Case vbCurrency
Exit "Currency"

Case vbDate
Exit "Date"

Case vbString
Exit "String"

Case vbObject
Exit "Object"

Case vbError
Exit "Error"

Case vbBoolean
Exit "Boolean"

Case vbVariant
Exit "Variant"

Case 13
Exit "IUnknown"

Case vbDecimal
Exit "Decimal"

Case 16
Exit "SByte"

Case vbByte
Exit "Byte"

Case 18
Exit "UInteger"

Case 19
Exit "ULong"

Case vbLongLong
Exit "LongLong"

Case 21
Exit "ULongLong"

Case 22
#If Win64 Then
Exit "LongLong"
#ElseIf Win16 Then
Exit "Integer"
#Else
Exit "Long"
#End If

Case 23
#If Win64 Then
Exit "ULongLong"
#ElseIf Win16 Then
Exit "UInteger"
#Else
Exit "ULong"
#End If

Case 24
Exit "Any"

Case 25
Exit "HResult"

Case 26
Exit "Pointer"

Case 27
Exit "SafeArray"

Case 28
Exit "CArray"

Case 29
Exit "UserDefinedType"

Case 30
Exit "LPStr"

Case 31
Exit "LPWStr"

Case 32
Exit "Record"

Case 64
Exit "FileTime"

Case 65
Exit "Blob"

Case 66
Exit "Stream"

Case 67
Exit "Storage"

Case 68
Exit "Streamed_Object"

Case 69
Exit "Stored_Object"

Case 70
Exit "Blob_Object"

Case 71
Exit "CF"

Case 72
Exit "ClsID"
End Select
End Function

Private Function ParFlags(ByVal Value As Long) As String
Dim Result As String

If Value And 1 Then Result = "In"
If Value And 2 Then Result &= " Out"
If Value And 4 Then Result &= " LCID"
If Value And 8 Then Result &= " RetVal"
If Value And 16 Then Result &= " Optional"
If Value And 32 Then Result &= " HasDefault"
If Value And 64 Then Result &= " HasCustData"
Exit Replace$(Trim$(Result), " ", ", ")
End Function

Private Sub PrintCustomString(ByVal Handle As Integer, ByRef TLib As TypeLibData, ByVal Index As Long)
Dim Pos As Long
Dim Length As Long
Dim Letters As Long

Print #Handle, """";
Length = TLib.CustomData(Index) >> 16

If Length Then
Pos = 3
Index += 1
Letters = TLib.CustomData(Index)
Letters >>= 16

Do
Print #Handle, ChrW$(Letters And &HFF);
Letters >>= 8
Pos += 1
Length -= 1
If Length = 0 Then Exit Do

If Pos = 5 Then
Pos = 1
Index += 1
Letters = TLib.CustomData(Index)
End If
Loop
End If

Print #Handle, """"
End Sub
End Module