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

Let's build a transpiler! Part 54

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

Zany Zooms

Even though I don't have a job anymore, once in a while I am called to work on some old projects as a free-lancer. Due to that, sometimes I need to join video conferences. There's nothing much to do there, but I am required to join just in case I need to answer something. This is another way to put it: These meetings are boring. Boring to death.
The other day I realized that if I'm listening to music on my computer, the other attendees cannot hear it. It makes sense, but I used to think my audio would be automatically shared with everyone.
After that, when joining such meetings, I put my music just loud enough so I can hear it and also what people are talking about. Of course, I'm using headphones, so when I unmute and talk, nobody hears my buzzing Electric Swing.
It is such an amazing finding, that - while in a meeting - I told my wife "After I've found out I can hear music during these meetings, everything changed to me!"
Except that, you know, I was not on mute. Uh, oh!
That was strike one.

There was a meeting that was scheduled very early in the morning. I put my cellphone to ring half an hour before the scheduled time and would join the meeting from my bed. I would have no time to take a shower, change clothes, and have a breakfast as I usually do. Mind you, we don't activate our cams during meetings, so I thought nothing about it. The meeting started and at some point, I was required to talk. Have you ever noticed how close the unmute button is to the activate cam one?
Well, yeah. I clicked the wrong button and while I was haphazardly trying to "unclick" it people saw me looking like this:

Me as a caveman
Credits: Toonify

That was strike two.

Sometimes we have to share our desktop to show everyone what we are doing or seeing.
I keep the source code for that old projects in another drive, so, when I needed to show it, I would open that drive and browse to the relevant folder. Until one day it dawned on me. I keep some... well, entertaining files in that same drive, in a folder with a very suggesting name (Sexxx, of all things!) Every time I opened that drive, everyone at the meeting would see it right there and would have no doubts about its contents.
Oh, my... It was almost as embarrassing as this.
That was strike three. Enough is enough.

Now, I join meetings wearing a cap and installed an app that uses shortcut keys to mute my mic. It has a very prominent indication in the middle of the screen whether it is on or off
And I renamed that folder to Chess.

Back to business

Last time, I said we would revisit our TLib dumper module. When I first made it, there were some things I did not know how to do. (How to enumerate the interfaces a coclass implemented, for instance.) As I said before, I read TheirCorp's manual several times, but there's too much missing there. Previously, I tried to find the source code mentioned in the manual but was unable to. This time, however, I succeeded! It is here. Due to that, I updated my version of TheirCorp's manual with the tidbits I could find in the source code. After carefully reading it, these are the main new "knowns:" But some unknowns still remain: Due to that, I was unable to complete my TLib compiler, but I updated the dumper. The code below has a bug fix and an improvement: It now lists the implemented interfaces (yay!)

Next week we'll see how to replicate VB's error management without resorting to non-portable code.

Andrej Biasic
2022-01-19

Public Module MsftTlib
Option Explicit

Public Const VT_Bstr_Blob = &HHFFF
Public Const VT_Vector = &H1000
Public Const VT_Array = &H2000 'vbArray
Public Const VT_ByRef = &H4000
Public Const VT_Reserved = &H8000

Public Const CC_FASTCALL = 0
Public Const CC_CDECL = 1
Public Const CC_MSCPASCAL = 2
Public Const CC_PASCAL = 2
Public Const CC_MACPASCAL = 3
Public Const CC_STDCALL = 4
Public Const CC_FPFASTCALL = 5
Public Const CC_SYSCALL = 6
Public Const CC_MPWCDECL = 7
Public Const CC_MPWPASCAL = 8
Public Const CC_MAX = 9

Public Const FUNC_VIRTUAL = 0
Public Const FUNC_PUREVIRTUAL = 1
Public Const FUNC_NONVIRTUAL = 2
Public Const FUNC_STATIC = 3
Public Const FUNC_DISPATCH = 4

Public Const FUNCFLAG_FRESTRICTED = 1
Public Const FUNCFLAG_FSOURCE = 2
Public Const FUNCFLAG_FBINDABLE = 4
Public Const FUNCFLAG_FREQUESTEDIT = 8
Public Const FUNCFLAG_FDISPLAYBIND = &H10
Public Const FUNCFLAG_FDEFAULTBIND = &H20
Public Const FUNCFLAG_FHIDDEN = &H40
Public Const FUNCFLAG_FUSESGETLASTERROR = &H80
Public Const FUNCFLAG_FDEFAULTCOLLELEM = &H100
Public Const FUNCFLAG_FUIDEFAULT = &H200
Public Const FUNCFLAG_FNONBROWSABLE = &H400
Public Const FUNCFLAG_FREPLACEABLE = &H800
Public Const FUNCFLAG_FIMMEDIATEBIND = &H1000

Public Const INVOKE_FUNC = 0
Public Const INVOKE_PROPERTYGET = 1
Public Const INVOKE_PROPERTYPUT = 2
Public Const INVOKE_PROPERTYPUTREF = 4

Public Const PARAMFLAG_NONE = 0
Public Const PARAMFLAG_FIN = 1
Public Const PARAMFLAG_FOUT = 2
Public Const PARAMFLAG_FLCID = 4
Public Const PARAMFLAG_FRETVAL = 8
Public Const PARAMFLAG_FOPT = &H10
Public Const PARAMFLAG_FHASDEFAULT = &H20
Public Const PARAMFLAG_FHASCUSTDATA = &H40

Public Const SYS_WIN16 = 0
Public Const SYS_WIN32 = 1
Public Const SYS_MAC = 2
Public Const SYS_WIN64 = 3

Public Const TKIND_ENUM = 0
Public Const TKIND_RECORD = 1
Public Const TKIND_MODULE = 2
Public Const TKIND_INTERFACE = 3
Public Const TKIND_DISPATCH = 4
Public Const TKIND_COCLASS = 5
Public Const TKIND_ALIAS = 6
Public Const TKIND_UNION = 7
Public Const TKIND_MAX = 8

Public Const TYPEFLAG_FAPPOBJECT = &H1
Public Const TYPEFLAG_FCANCREATE = &H2
Public Const TYPEFLAG_FLICENSED = &H4
Public Const TYPEFLAG_FPREDECLID = &H8
Public Const TYPEFLAG_FHIDDEN = &H10
Public Const TYPEFLAG_FCONTROL = &H20
Public Const TYPEFLAG_FDUAL = &H40
Public Const TYPEFLAG_FNONEXTENSIBLE = &H80
Public Const TYPEFLAG_FOLEAUTOMATION = &H100
Public Const TYPEFLAG_FRESTRICTED = &H200
Public Const TYPEFLAG_FAGGREGATABLE = &H400
Public Const TYPEFLAG_FREPLACEABLE = &H800
Public Const TYPEFLAG_FDISPATCHABLE = &H1000
Public Const TYPEFLAG_FREVERSEBIND = &H2000

Public Const FUNCKIND_VIRTUAL = 0
Public Const FUNCKIND_PUREVIRTUAL = 1
Public Const FUNCKIND_NONVIRTUAL = 2
Public Const FUNCKIND_STATIC = 3
Public Const FUNCKIND_DISPATCH = 4

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 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, "GUID : " & GetGuid(TLib.GUIDTable, ImpFileTxt.TlbImpLib.GUIDOffset)
Print #Handle,

Count = 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 TKIND_INTERFACE, TKIND_DISPATCH, TKIND_COCLASS
Print #Handle, "Implements: " & GetImpls(TLib, TInfo)
Print #Handle, "Version : " & TInfo.Version
End Select

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

If TInfo.DataType1Offset < 0 Then
Print #Handle, GetDataType(TInfo.DataType1Offset And &HFF)
Else
Tmp = TInfo.DataType1Offset \ Len(TypeDescriptor) + 1
Tmp = LShift(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 TKIND_COCLASS
Rem DataType1 is an offset into RefTable
Tmp = TInfo.DataType1Offset \ Len(RefRecord) + 1
Tmp = TLib.ReferencesTable(Tmp).RefType \ Len(TypeInfo) + 1

Case TKIND_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 = 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(RShift(FRec.FKCCIC And &H70, 4))
Print #Handle, " Has custom data ? " & IIf(FRec.FKCCIC And &H80, "True", "False")
Print #Handle, " Calling convention: " & CallConvs(RShift(FRec.FKCCIC And &HF00, 8))
Print #Handle, " Has default value ? " & IIf(FRec.FKCCIC And &H1000, "True", "False")
Print #Handle, " DispID : " & FPRec.MethodOrPropertyID(Kdx);
Print #Handle, " (&H" & Hex$(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(TypeDescriptor) + 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 = LShift(CLng(TDesc.Value4), 16) Or TDesc.Value3
Count = Count \ Len(TypeDescriptor) + 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 = LShift(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 = LShift(CLng(TDesc.Value4), 16) Or TDesc.Value3
Count = Count \ Len(ImpInfo) + 1
IInfo = TLib.ImportInfoTable(Count)

ImpFile = GetImpFile(TLib.ImportedTypeLibTable, IInfo.ImportFileOffset)
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 = Key & "\win64"
#Else
Key = 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 = 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 = 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 = Idx + 1
Length = Length - Len(TlbImpLib)
ReDim Preserve .ImportedTypeLibTable(1 To Idx)
Get #Handle, , .ImportedTypeLibTable(Idx).TlbImpLib
Count = RShift(.ImportedTypeLibTable(Idx).TlbImpLib.SizeTimes4, 2)

If Count Then
.ImportedTypeLibTable(Idx).Text = Space$(Count)
Get #Handle, , .ImportedTypeLibTable(Idx).Text
Length = 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 = VBA.String$(Length, " ")
Get #Handle, , .NameTable(Idx).Text

.NameTable(Idx).Offset = Off
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 = 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 = Idx + 1
ReDim Preserve .StringTable(1 To Idx)
Get #Handle, , .StringTable(Idx).Length
Length = .StringTable(Idx).Length
.StringTable(Idx).Text = VBA.String$(Length, " ")
Get #Handle, , .StringTable(Idx).Text
Length = Length + SizeOf([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 = Count - .StringTable(Idx).Length - Length - SizeOf([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 = RShift(.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 = RShift(.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 = 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
Do
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 * SizeOf([Long])

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .HelpContext

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .HelpString

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .Entry

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .Reserved2

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .Reserved3

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .HelpStringContext

If Length = 0 Then If .FKCCIC And &H1000 Then GoTo Data Else If .ParameterCount Then GoTo Parms Else Exit Do
Length = Length - SizeOf([Long])
Get #Handle, , .CustomDataOffset

If Length = 0 Then If .ParameterCount Then GoTo Parms Else Exit Do
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
Loop While False
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
Do
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 Exit Do
Get #Handle, , .Unknown
Length = Length - SizeOf([Long])

If Length = 0 Then Exit Do
Get #Handle, , .HelpContext
Length = Length - SizeOf([Long])

If Length = 0 Then Exit Do
Get #Handle, , .HelpString
Length = Length - SizeOf([Long])

If Length = 0 Then Exit Do
Get #Handle, , .Reserved
Length = Length - SizeOf([Long])

If Length = 0 Then Exit Do
Get #Handle, , .CustomDataOffset
Length = Length - SizeOf([Long])

If Length = 0 Then Exit Do
Get #Handle, , .HelpStringContext
Length = Length - SizeOf([Long])
End With
Loop While False
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
GetName = Names(Idx).Text
Exit Function

Case Is > Off
Exit For
End Select
Next

GetName = "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 = Result & Format$(Hex$(G.GUID(2)), "@@")
Result = Result & Format$(Hex$(G.GUID(1)), "@@")
Result = Result & Format$(Hex$(G.GUID(0)), "@@")
Result = Result & "-"
Result = Result & Format$(Hex$(G.GUID(5)), "@@")
Result = Result & Format$(Hex$(G.GUID(4)), "@@")
Result = Result & "-"
Result = Result & Format$(Hex$(G.GUID(7)), "@@")
Result = Result & Format$(Hex$(G.GUID(6)), "@@")
Result = Result & "-"
Result = Result & Format$(Hex$(G.GUID(8)), "@@")
Result = Result & Format$(Hex$(G.GUID(9)), "@@")
Result = Result & "-"
Result = Result & Format$(Hex$(G.GUID(10)), "@@")
Result = Result & Format$(Hex$(G.GUID(11)), "@@")
Result = Result & Format$(Hex$(G.GUID(12)), "@@")
Result = Result & Format$(Hex$(G.GUID(13)), "@@")
Result = Result & Format$(Hex$(G.GUID(14)), "@@")
Result = Result & Format$(Hex$(G.GUID(15)), "@@}")
GetGuid = 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
GetString = TLib.StringTable(Idx).Text
Exit Function
End If

Length = TLib.StringTable(Idx).Length + SizeOf([Integer])
Count = Count + Length
If Length And 3 Then Count = 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 = Result & " CANCREATE"
If TYPEFLAG_FLICENSED And Value Then Result = Result & " LICENSED"
If TYPEFLAG_FPREDECLID And Value Then Result = Result & " PREDECLID"
If TYPEFLAG_FHIDDEN And Value Then Result = Result & " HIDDEN"
If TYPEFLAG_FCONTROL And Value Then Result = Result & " CONTROL"
If TYPEFLAG_FDUAL And Value Then Result = Result & " DUAL"
If TYPEFLAG_FNONEXTENSIBLE And Value Then Result = Result & " NONEXTENSIBLE"
If TYPEFLAG_FOLEAUTOMATION And Value Then Result = Result & " OLEAUTOMATION"
If TYPEFLAG_FRESTRICTED And Value Then Result = Result & " RESTRICTED"
If TYPEFLAG_FAGGREGATABLE And Value Then Result = Result & " AGGREGATABLE"
If TYPEFLAG_FREPLACEABLE And Value Then Result = Result & " REPLACEABLE"
If TYPEFLAG_FDISPATCHABLE And Value Then Result = Result & " DISPATCHABLE"
If TYPEFLAG_FREVERSEBIND And Value Then Result = Result & " REVERSEBIND"
Flags = Replace$(Trim$(Result), " ", ", ")
End Function

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

Case vbNull
GetDataType = "Null"

Case vbInteger
GetDataType = "Integer"

Case vbLong
GetDataType = "Long"

Case vbSingle
GetDataType = "Single"

Case vbDouble
GetDataType = "Double"

Case vbCurrency
GetDataType = "Currency"

Case vbDate
GetDataType = "Date"

Case vbString
GetDataType = "String"

Case vbObject
GetDataType = "Object"

Case vbError
GetDataType = "Error"

Case vbBoolean
GetDataType = "Boolean"

Case vbVariant
GetDataType = "Variant"

Case 13
GetDataType = "IUnknown"

Case vbDecimal
GetDataType = "Decimal"

Case 16
GetDataType = "SByte"

Case vbByte
GetDataType = "Byte"

Case 18
GetDataType = "UInteger"

Case 19
GetDataType = "ULong"

Case vbLongLong
GetDataType = "LongLong"

Case 21
GetDataType = "ULongLong"

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

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

Case 24
GetDataType = "Any"

Case 25
GetDataType = "HResult"

Case 26
GetDataType = "Pointer"

Case 27
GetDataType = "SafeArray"

Case 28
GetDataType = "CArray"

Case 29
GetDataType = "UserDefinedType"

Case 30
GetDataType = "LPStr"

Case 31
GetDataType = "LPWStr"

Case 32
GetDataType = "Record"

Case 64
GetDataType = "FileTime"

Case 65
GetDataType = "Blob"

Case 66
GetDataType = "Stream"

Case 67
GetDataType = "Storage"

Case 68
GetDataType = "Streamed_Object"

Case 69
GetDataType = "Stored_Object"

Case 70
GetDataType = "Blob_Object"

Case 71
GetDataType = "CF"

Case 72
GetDataType = "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 = Result & " Out"
If Value And 4 Then Result = Result & " LCID"
If Value And 8 Then Result = Result & " RetVal"
If Value And 16 Then Result = Result & " Optional"
If Value And 32 Then Result = Result & " HasDefault"
If Value And 64 Then Result = Result & " HasCustData"
ParFlags = 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 = WShift(TLib.CustomData(Index), 16)

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

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

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

Print #Handle, """"
End Sub

Private Function GetImpFile(ByRef ImpLibTable() As TlbImpLibWithText, ByVal Offset As Long) As TlbImpLib
Dim Idx As Long
Dim Size As Long
Dim Length As Long

Idx = 1
Size = Len(TlbImpLib)

Do While Offset <> 0
Length = Len(ImpLibTable(Idx).Text)
If Length Mod Size <> 0 Then Length = Length + Size - Length Mod Size
Offset = Offset - Size - Length
Idx = Idx + 1
Loop

GetImpFile = ImpLibTable(Idx).TlbImpLib
End Function

Private Function GetImpls(ByRef TLib As TypeLibData, ByRef TInfo As TypeInfo) As String
Dim Idx As Long
Dim Offset As Long
Dim Result As String

Select Case TInfo.TypeKind And &HF
Case TKIND_DISPATCH
Rem Reference to the inherited interface
Idx = TInfo.DataType1Offset

If Idx <> -1 Then
Idx = Idx - 1
' What's next?
End If

Case TKIND_COCLASS
Offset = TInfo.DataType1Offset

Do While Offset >= 0
Idx = Offset \ Len(RefRecord) + 1
Offset = TLib.ReferencesTable(Idx).NextOffset
Idx = TLib.ReferencesTable(Idx).RefType
Idx = Idx \ Len(TypeInfo) + 1
Idx = TLib.TypeInfoTable(Idx).NameOffset
Result = Result & ", " & GetName(TLib.NameTable, Idx)
Loop
End Select

GetImpls = Mid$(Result, 3)
End Function
End Module

Public Class Register
Option Explicit

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" ( _
ByVal dwFlags As Long, _
ByRef lpSource As Long, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
ByRef Arguments As Long _
) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" ( _
ByVal hKey As LongPtr, _
ByVal lpSubKey As String, _
ByVal Reserved As Long, _
ByVal lpClass As String, _
ByVal dwOptions As Long, _
ByVal samDesired As Long, _
ByVal lpSecurityAttributes As LongPtr, _
ByRef phkResult As LongPtr, _
ByRef lpdwDisposition As Long _
) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
ByVal hKey As LongPtr, _
ByVal Name As String, _
ByVal Reserved As Long, _
ByRef lType As Long, _
ByVal Value As String, _
ByRef Size As Long _
) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal hKey As LongPtr, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpData As String, _
ByVal cbData As Long _
) As Long

Private Const MY_ERROR As Long = 7691
Private Const MY_APP As String = "Register"

Public Enum hKey
ClassesRoot = &H80000000
CurrentUser
LocalMachine
Users
PerformanceData
CurrentConfig
DynData
End Enum

Public Function ReadReg(ByVal Key As hKey, ByVal SubKey As String, Optional ByVal ValName As String, Optional ByVal DefaultValue As String) As String
Const KEY_QUERY_VALUE As Long = 1
Dim Size As Long
Dim Handle As Long
Dim Hr As Long
Dim Result As String * 512
Dim Value As Variant

Size = Len(Result)
RegCreateKeyEx Key, SubKey, 0, vbNullString, 0, KEY_QUERY_VALUE, 0, Handle, ByVal 0
Hr = RegQueryValueEx(Handle, ValName, 0, ByVal 0, Result, Size)

If Hr Then
Value = Left$(Result, Size)
ReadReg = Replace(Value, vbNullChar, "")
Else
Debug.Print GetErrorMessage(Hr)
ReadReg = DefaultValue
End If

RegCloseKey Handle
End Function

Public Sub WriteReg(ByVal Key As hKey, ByVal SubKey As String, ByVal RegValue As String)
Const KEY_ALL_ACCESS = &HF003F
Dim Pos As Long
Dim Handle As Long
Dim Result As Long
Dim ValName As String
Dim Reserved As String

Pos = InStrRev(SubKey, "\")
ValName = Mid$(SubKey, Pos + 1)
SubKey = Left$(SubKey, Pos)

Pos = RegCreateKeyEx(Key, SubKey, 0, Reserved, 0, KEY_ALL_ACCESS, 0, Handle, Result)
If Pos Then Err.Raise vbObjectError + MY_ERROR + 4, MY_APP & "::WriteReg", "Unable to open key " & SubKey

Pos = RegSetValueEx(Handle, ValName, 0, 1, RegValue, Len(RegValue))
RegCloseKey Handle
End Sub

Private Function GetErrorMessage(ByVal ErrorNo As Long) As String
Const LANG_NEUTRAL As Long = 0
Const SUBLANG_DEFAULT As Long = 1
Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Dim RetVal As Long
Dim Lang As Long
Dim Flags As Long
Dim Buffer As String

Flags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS
Lang = LANG_NEUTRAL Or (SUBLANG_DEFAULT * 1024)
Buffer = Space$(256)
RetVal = FormatMessage(Flags, 0, ErrorNo, Lang, Buffer, Len(Buffer), 0&)

If RetVal Then
GetErrorMessage = Left$(Buffer, RetVal)
'Else
'MsgBox "Error while retrieving error message.", vbCritical
End If
End Function
End Class