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:
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:"
For each available GUID, calculate its hash, then store that GUID's offset at the Lib Table's entry pointed to by the hash.
The algorithm is:
Function HashGuid(ByRef Bytes() As Byte) As Byte Dim Idx As Integer
For Idx = 0 To 6 Step 2
HashGuid = HashGuid Xor Bytes(Idx) Next
HashGuid = HashGuid And &H1F End Function
The same goes for the Unknown1 and the Name Table.
For each name, its offset is stored into Unknown1's entry pointed by hashing the name.
The hashing algorithm for names is a little more involved, though:
Function HashName(ByVal SysKind As Integer, ByVal LCID As Integer, ByVal Name As String) As Byte Dim IsMac As Boolean Dim HashTb() As Byte Dim Ch As Integer Dim Result As Long Dim Idx As Long
IsMac = SysKind = SYS_MAC
Name = StrConv(Name, vbFromUnicode)
Rem Select a hash table according to the provided LCID Select Case LCID And &H3FF Case (...)
Tb = (...)
(...) End Select
For Idx = 1 To LenB(Name) 'MidB$(Name, Idx, 1) |> AscB |> CInt -> Ch
Ch = CInt(AscB(MidB$(Name, Idx, 1))) If Ch > &H7F And IsMac Then Ch = Ch + &H80
Rem Avoiding overflow If Result >= &H6EB_3E45 Then
Result = CLng(Result * 37^ Mod &H100000000^)
ElseIf Result <= &H914_C1BB Then
Result = -CLng(Result * 37^ Mod &H100000000^)
Else
Result = Result * 37 End If
Result = UAdd(Result, HashTb(Ch)) Next
Result = Result \ &H1003F And &H7F
HashName = CByte(Result) End Function
A class' TypeInfo.DataType1 is an offset into the References Tables.
There, its RefType is an offset into the TypeInfo to the first implemented interface.
We can find the next implemented interface in NextOffset, that is another offset into the References Table.
Then rinse and repeat until we find a NextOffset equal to -1 marking the end of the chain.
But some unknowns still remain:
I don't know why the Offsets to TypeInfos are laid out the way they are.
Those entries do not seem to have a discernible order.
I'm not sure what goes into the Custom Data section nor how it is used.
WTF means "If TypeKind is an interface, then DataType1 is a reference to inherited interface?"
How do references differ from offsets?
Are they some table's zero-based indexes?
If it is so, which table??
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 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
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)
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
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
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
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
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
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
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
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
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 = 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