'\ This VBA project browses typelibs at runtime via low level vTable calls.
'\ Requiremets:
'\ ===========
' - This project requires a reference to Visual Basic for Applications Extensibility.
' - 'Trust access to Visual Basic Project' must also be set.
Option Explicit
Public Enum SEARCH_TARGET
Class_
Interface_
Module_
Enum_
End Enum
Private Const TKIND_ENUM = 0&
Public Enum TKIND
EI = TKIND_ENUM
MI = TKIND_ENUM + 2& 'TKIND_MODULE
II = TKIND_ENUM + 3& 'TKIND_INTERFACE
CI = TKIND_ENUM + 5& 'TKIND_COCLASS
DI = TKIND_ENUM + 4& 'TKIND_DISPATCH
End Enum
Private Enum VarEnum
VT_EMPTY = 0&
VT_NULL = 1&
VT_I2 = 2&
VT_I4 = 3&
VT_R4 = 4&
VT_R8 = 5&
VT_CY = 6&
VT_DATE = 7&
VT_BSTR = 8&
VT_DISPATCH = 9&
VT_ERROR = 10&
VT_BOOL = 11&
VT_VARIANT = 12&
VT_UNKNOWN = 13&
VT_DECIMAL = 14&
VT_I1 = 16&
VT_UI1 = 17&
VT_UI2 = 18&
VT_UI4 = 19&
VT_I8 = 20&
VT_UI8 = 21&
VT_INT = 22&
VT_UINT = 23&
VT_VOID = 24&
VT_HRESULT = 25&
VT_PTR = 26&
VT_SAFEARRAY = 27&
VT_CARRAY = 28&
VT_USERDEFINED = 29&
VT_LPSTR = 30&
VT_LPWSTR = 31&
VT_RECORD = 36&
VT_FILETIME = 64&
VT_BLOB = 65&
VT_STREAM = 66&
VT_STORAGE = 67&
VT_STREAMED_OBJECT = 68&
VT_STORED_OBJECT = 69&
VT_BLOB_OBJECT = 70&
VT_CF = 71&
VT_CLSID = 72&
VT_BSTR_BLOB = &HFFF&
VT_VECTOR = &H1000&
VT_ARRAY = &H2000&
VT_BYREF = &H4000&
VT_RESERVED = &H8000&
VT_ILLEGAL = &HFFFF&
End Enum
#If Win64 Then
Private Const NULL_PTR = 0^
Private Const PTR_LEN = 8&
#Else
Private Const NULL_PTR = 0&
Private Const PTR_LEN = 4&
#End If
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare PtrSafe Function StringFromIID Lib "ole32" (ByRef lpsz As GUID, ByVal rclsid As LongPtr) As Long
Private Declare PtrSafe Function LoadTypeLibEx Lib "OleAut32" (ByVal szFile As LongPtr, ByVal regkind As Long, ByRef pptlib As IUnknown) As Long
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetModuleInformation Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, mInfo As MODULEINFO, ByVal cbSize As Long) As Long
Private Declare PtrSafe Function GetModuleFileNameExW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare PtrSafe Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As LongPtr, lphModule As LongPtr, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare PtrSafe Function GetModuleBaseNameW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare PtrSafe Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As LongPtr, ByVal lpFileName As String, ByVal nSize As Long) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As LongPtr)
Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
Private Declare Function StringFromIID Lib "ole32" (ByRef lpsz As GUID, ByVal rclsid As LongPtr) As Long
Private Declare Function LoadTypeLibEx Lib "OleAut32" (ByVal szFile As LongPtr, ByVal regkind As Long, ByRef pptlib As IUnknown) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As LongPtr
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long
Private Declare Function GetModuleInformation Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, mInfo As MODULEINFO, ByVal cbSize As Long) As Long
Private Declare Function GetModuleFileNameExW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As LongPtr, lphModule As LongPtr, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseNameW Lib "psapi.dll" (ByVal hProcess As LongPtr, ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare Function GetModuleFileNameW Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpFileName As LongPtr, ByVal nSize As Long) As Long
Private Declare Function GetModuleHandleW Lib "kernel32" (ByVal lpModuleName As LongPtr) As LongPtr
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As LongPtr, ByVal lpFileName As String, ByVal nSize As Long) As Long
#End If
Public Type FUNC_INFO
Name As String
memid As Long
CallConvention As Long
funckind As Long
VTBLOffset As Long
INVOKEKIND As String
ParamsCount As Long
OptParamsCount As Long
ReturnType As String
End Type
Public Type INTERFACE_INFO
ptr As LongPtr
GUID As String
lcid As Long
memidConstructor As Long
memidDestructor As Long
Name As String
MembersCount As Long
InterfacesCount As Long
wMajorVerNum As Integer
wMinorVerNum As Integer
End Type
Public Type SPECIAL_ENUMS
'Special vba ENUMS not defined in the enumerations module.
Caption() As String
Value() As String
End Type
Public Type ENUM_VALS
Name As String
Value As String
End Type
Public Type TEXT_STRUCT
Caption As String
Value As String
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0& To 7&) As Byte
End Type
Private Type LARGE_INT
LowPart As Long
HighPart As Long
End Type
Private Type DUMMYUNIONNAME_TYPE
oInst As Long
lpvarValue As LongPtr
End Type
Private Type VARDESC
memid As Long
lpstrSchema As LongPtr
DUMMYUNIONNAME As LongPtr
elemdescVar As Long
wVarFlags As Long
varkind As Long
End Type
Private Type TTYPEDESC
pTypeDesc As LongPtr
vt As Integer
End Type
Private Type TPARAMDESC
pPARAMDESCEX As LongPtr
wParamFlags As Integer
End Type
Private Type TELEMDESC
tdesc As TTYPEDESC
pdesc As TPARAMDESC
End Type
Private Type TYPEATTR
aGUID As GUID
lcid As Long
dwReserved As Long
memidConstructor As Long
memidDestructor As Long
lpstrSchema As LongPtr
cbSizeInstance As Integer
typekind As Long
cFuncs As Integer
cVars As Integer
cImplTypes As Integer
cbSizeVft As Integer
cbAlignment As Integer
wTypeFlags As Integer
wMajorVerNum As Integer
wMinorVerNum As Integer
tdescAlias As Long
idldescType As Long
End Type
Private Type FUNCDESC
memid As Long
lReserved1 As LongPtr
lprgelemdescParam As LongPtr
funckind As Long
INVOKEKIND As Long
CallConv As Long
cParams As Integer
cParamsOpt As Integer
oVft As Integer
cReserved2 As Integer
elemdescFunc As TELEMDESC
wFuncFlags As Integer
End Type
Private Type MODULEINFO
lpBaseOfDll As LongPtr
SizeofImage As Long
EntryPoint As LongPtr
End Type
Private Type INFO
CI() As INTERFACE_INFO
MI() As INTERFACE_INFO
EI() As INTERFACE_INFO
DI() As INTERFACE_INFO
End Type
Private Type ARRAYS
arrClasses() As INTERFACE_INFO
arrInterfaces() As INTERFACE_INFO
arrDisps() As INTERFACE_INFO
arrModules() As INTERFACE_INFO
arrEnums() As INTERFACE_INFO
arrTypes() As SEARCH_TARGET
arrNames() As String
arrFuncPtrs() As FUNC_INFO
arrEnumPtrs() As ENUM_VALS
arrPtrs() As LongPtr
arrOtherInfo1() As TEXT_STRUCT
arrOtherInfo2() As TEXT_STRUCT
End Type
Public tArrays As ARRAYS
Function RetrieveLibInfo(ByVal sFile As String) As Boolean
Dim lArrRows As Long
Dim i As Long, j As Long
Call EraseArrays
With tArrays
.arrClasses = TypeInfoFromCOMLib(sFile, CI).CI
If (Not Not .arrClasses) = False Then
Exit Function
End If
For i = LBound(.arrClasses) To UBound(.arrClasses)
.arrInterfaces = InterFacesFromClass(.arrClasses(i))
For j = LBound(.arrInterfaces) To UBound(.arrInterfaces)
ReDim Preserve .arrNames(lArrRows): ReDim Preserve .arrPtrs(lArrRows)
ReDim Preserve .arrTypes(lArrRows): ReDim Preserve .arrOtherInfo1(lArrRows)
ReDim Preserve .arrOtherInfo2(lArrRows)
.arrNames(lArrRows) = ChrW(&H25A0) & " " & .arrInterfaces(j).Name
.arrPtrs(lArrRows) = .arrInterfaces(j).ptr: .arrTypes(lArrRows) = Class_
.arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrInterfaces(j), False)
.arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrInterfaces(j), True)
lArrRows = lArrRows + 1&
Next j
Next i
.arrDisps = TypeInfoFromCOMLib(sFile, DI).DI
If Not Not .arrDisps Then
For i = LBound(.arrDisps) To UBound(.arrDisps)
ReDim Preserve .arrNames(lArrRows): ReDim Preserve .arrPtrs(lArrRows)
ReDim Preserve .arrTypes(lArrRows): ReDim Preserve .arrOtherInfo1(lArrRows)
ReDim Preserve .arrOtherInfo2(lArrRows)
.arrNames(lArrRows) = ChrW(&H25A0) & " " & .arrDisps(i).Name
.arrPtrs(lArrRows) = .arrDisps(i).ptr: .arrTypes(lArrRows) = Interface_
.arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrDisps(i), False)
.arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrDisps(i), True)
lArrRows = lArrRows + 1&
Next
End If
.arrModules = TypeInfoFromCOMLib(sFile, MI).MI
If Not Not .arrModules Then
For i = LBound(.arrModules) To UBound(.arrModules)
ReDim Preserve .arrNames(lArrRows): ReDim Preserve .arrPtrs(lArrRows)
ReDim Preserve .arrTypes(lArrRows): ReDim Preserve .arrOtherInfo1(lArrRows)
ReDim Preserve .arrOtherInfo2(lArrRows)
.arrNames(lArrRows) = ChrW(&H25E5) & " " & .arrModules(i).Name
.arrPtrs(lArrRows) = .arrModules(i).ptr: .arrTypes(lArrRows) = Module_
.arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrModules(i), False)
.arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrModules(i), True)
lArrRows = lArrRows + 1&
Next i
End If
.arrEnums = TypeInfoFromCOMLib(sFile, EI).EI
If Not Not .arrEnums Then
For i = LBound(.arrEnums) To UBound(.arrEnums)
ReDim Preserve .arrNames(lArrRows): ReDim Preserve .arrPtrs(lArrRows)
ReDim Preserve .arrTypes(lArrRows): ReDim Preserve .arrOtherInfo1(lArrRows)
ReDim Preserve .arrOtherInfo2(lArrRows)
.arrNames(lArrRows) = ChrW(&H25CD) & " " & .arrEnums(i).Name
.arrPtrs(lArrRows) = .arrEnums(i).ptr: .arrTypes(lArrRows) = Enum_
.arrOtherInfo1(lArrRows) = BuildClassInfoString(.arrEnums(i), False)
.arrOtherInfo2(lArrRows) = BuildClassInfoString(.arrEnums(i), True)
lArrRows = lArrRows + 1&
Next i
End If
End With
RetrieveLibInfo = True
End Function
Sub EraseArrays()
With tArrays
Erase .arrClasses(): Erase .arrInterfaces()
Erase .arrDisps(): Erase .arrModules()
Erase .arrEnums(): Erase .arrTypes()
Erase .arrNames(): Erase .arrFuncPtrs()
Erase .arrEnumPtrs(): Erase .arrPtrs()
Erase .arrOtherInfo1(): Erase .arrOtherInfo2()
End With
End Sub
Function TypeInfoFromCOMLib(ByVal sLibFile As String, ByVal eRequestedInfo As TKIND) As INFO
Const REGKIND_NONE = 2&, MEMBERID_NIL = -1&
Const TKIND_COCLASS = 5&, TKIND_MODULE = 2&, TKIND_ENUM = 0&, TKIND_DISPATCH = 4&
Const S_OK = 0&, CC_STDCALL = 4&
Dim pTKind As LongPtr, ppTInfo As LongPtr, farPtr As LongPtr, psGUID As LongPtr
Dim tClassInfo As INTERFACE_INFO, tModuleInfo As INTERFACE_INFO
Dim tDispInfo As INTERFACE_INFO, tEnumInfo As INTERFACE_INFO
Dim tInfoArray As INFO
Dim tTYPEATTR As TYPEATTR
Dim unkTypLib As stdole.IUnknown
Dim i As Long, j As Long, lRet As Long, lInfoCount As Long
Dim sName As String
lRet = LoadTypeLibEx(StrPtr(sLibFile), REGKIND_NONE, unkTypLib)
If lRet <> S_OK Then
MsgBox "Unable to load the " & sLibFile & " library.": Exit Function
End If
lInfoCount = vtblCall(ObjPtr(unkTypLib), 3& * PTR_LEN, vbLong, CC_STDCALL) 'ITypeLib::GetTypeInfoCount
For i = 0& To lInfoCount - 1&
lRet = vtblCall(ObjPtr(unkTypLib), 5& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pTKind)) ' ITypeLib::GetTypeInfoType
If lRet <> S_OK Then
MsgBox "Unable to retrieve the type of a type description.": Exit Function
End If
If pTKind = eRequestedInfo Then
Select Case eRequestedInfo
Case Is = CI
ReDim Preserve tInfoArray.CI(j)
Case Is = MI
ReDim Preserve tInfoArray.MI(j)
Case Is = DI
ReDim Preserve tInfoArray.DI(j)
Case Is = EI
ReDim Preserve tInfoArray.EI(j)
End Select
lRet = vtblCall(ObjPtr(unkTypLib), 4& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(ppTInfo)) 'ITypeLib::GetTypeInfo
If lRet <> S_OK Then
MsgBox "Unable to retrieve the specified type description in the library.": Exit Function
End If
lRet = vtblCall(ppTInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr)) 'ITypeInfo::GetTypeAttr
If lRet <> S_OK Then
MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
Exit Function
End If
Call CopyMemory(tTYPEATTR, ByVal farPtr, LenB(tTYPEATTR))
lRet = vtblCall(ppTInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseTypeAttr
Call StringFromIID(tTYPEATTR.aGUID, VarPtr(psGUID))
lRet = vtblCall(ppTInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, MEMBERID_NIL, VarPtr(sName), NULL_PTR, NULL_PTR, NULL_PTR) 'ITypeInfo::GetDocumentation
If lRet <> S_OK Then
MsgBox "Unable to retrieve the documentation string.": Exit Function
End If
Select Case pTKind
Case Is = TKIND_COCLASS
With tClassInfo
.ptr = ppTInfo
.GUID = GetStrFromPtrW(psGUID)
.lcid = tTYPEATTR.lcid
.memidConstructor = tTYPEATTR.memidConstructor
.memidDestructor = tTYPEATTR.memidDestructor
.Name = sName
.MembersCount = tTYPEATTR.cFuncs
.InterfacesCount = tTYPEATTR.cImplTypes
.wMajorVerNum = tTYPEATTR.wMajorVerNum
.wMinorVerNum = tTYPEATTR.wMinorVerNum
End With
tInfoArray.CI(j) = tClassInfo
Case Is = TKIND_MODULE
With tModuleInfo
.ptr = ppTInfo
.GUID = GetStrFromPtrW(psGUID)
.lcid = tTYPEATTR.lcid
.memidConstructor = tTYPEATTR.memidConstructor
.memidDestructor = tTYPEATTR.memidDestructor
.Name = sName
.MembersCount = tTYPEATTR.cFuncs + tTYPEATTR.cVars
.InterfacesCount = tTYPEATTR.cImplTypes
.wMajorVerNum = tTYPEATTR.wMajorVerNum
.wMinorVerNum = tTYPEATTR.wMinorVerNum
End With
tInfoArray.MI(j) = tModuleInfo
Case Is = TKIND_DISPATCH
With tDispInfo
.ptr = ppTInfo
.GUID = GetStrFromPtrW(psGUID)
.lcid = tTYPEATTR.lcid
.memidConstructor = tTYPEATTR.memidConstructor
.memidDestructor = tTYPEATTR.memidDestructor
.Name = sName
.MembersCount = tTYPEATTR.cFuncs + tTYPEATTR.cVars
.InterfacesCount = tTYPEATTR.cImplTypes
.wMajorVerNum = tTYPEATTR.wMajorVerNum
.wMinorVerNum = tTYPEATTR.wMinorVerNum
End With
tInfoArray.DI(j) = tDispInfo
Case Is = TKIND_ENUM
With tEnumInfo
.ptr = ppTInfo
.GUID = GetStrFromPtrW(psGUID)
.lcid = tTYPEATTR.lcid
.memidConstructor = tTYPEATTR.memidConstructor
.memidDestructor = tTYPEATTR.memidDestructor
.Name = sName
.MembersCount = tTYPEATTR.cVars
.wMajorVerNum = tTYPEATTR.wMajorVerNum
.wMinorVerNum = tTYPEATTR.wMinorVerNum
End With
tInfoArray.EI(j) = tEnumInfo
End Select
j = j + 1&
End If
Next
TypeInfoFromCOMLib = tInfoArray
End Function
Function GetFuncs(ByVal ppTInfo As LongPtr, Optional ByVal FuncCallType As VbCallType, Optional ByVal unk As Boolean) As FUNC_INFO()
Const CC_STDCALL = 4&, S_OK = 0&
Dim aTYPEATTR() As LongPtr, aFUNCDESC() As LongPtr, farPtr As LongPtr
Dim tTYPEATTR As TYPEATTR, tFuncDesc As FUNCDESC, tFuncDescArray() As FUNC_INFO
Dim aGUID(0& To 11&) As Long
Dim lRet As Long, lFuncsCount As Long, n As Long
Dim sFuncName As String
Dim IUnkIDisp As Variant
lRet = vtblCall(ppTInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr)) 'ITypeInfo::GetTypeAttr
If lRet <> S_OK Then
MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
Exit Function
End If
Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal farPtr, LenB(tTYPEATTR))
ReDim aTYPEATTR(LenB(tTYPEATTR))
Call CopyMemory(ByVal VarPtr(aTYPEATTR(0&)), tTYPEATTR, UBound(aTYPEATTR))
lRet = vtblCall(ppTInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseTypeAttr
If tTYPEATTR.cFuncs Then
For lFuncsCount = 0& To tTYPEATTR.cVars + tTYPEATTR.cFuncs - 1&
lRet = vtblCall(ppTInfo, 5& * PTR_LEN, vbLong, CC_STDCALL, lFuncsCount, VarPtr(farPtr)) 'ITypeInfo::GetFuncDesc
If farPtr = NULL_PTR Then Exit Function
If lRet <> S_OK Then
MsgBox "Unable to retrieve the FUNCDESC structure that contains information about a specified function."
Exit Function
End If
If farPtr = NULL_PTR Then GoTo NextFunc
Call CopyMemory(ByVal VarPtr(tFuncDesc), ByVal farPtr, LenB(tFuncDesc))
ReDim aFUNCDESC(LenB(tFuncDesc))
Call CopyMemory(ByVal VarPtr(aFUNCDESC(0)), tFuncDesc, UBound(aFUNCDESC))
lRet = vtblCall(ppTInfo, 20& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseFuncDesc
lRet = vtblCall(ppTInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, aFUNCDESC(0), VarPtr(sFuncName), NULL_PTR, NULL_PTR, NULL_PTR) 'ITypeInfo::GetDocumentation
If lRet <> S_OK Then
MsgBox "Unable to retrieve the documentation string.": Exit Function
End If
IUnkIDisp = Array("QueryInterface", "AddRef", "Release", "GetTypeInfoCount", "GetTypeInfo", "GetIDsOfNames", "Invoke")
If IsError(Application.Match(sFuncName, IUnkIDisp, 0&)) = False And unk = False Then GoTo NextFunc
With tFuncDesc
If (.INVOKEKIND And FuncCallType) = .INVOKEKIND Then
ReDim Preserve tFuncDescArray(n)
tFuncDescArray(n).Name = sFuncName
tFuncDescArray(n).memid = .memid
tFuncDescArray(n).CallConvention = .CallConv
tFuncDescArray(n).funckind = .funckind
tFuncDescArray(n).VTBLOffset = .oVft
tFuncDescArray(n).INVOKEKIND = Switch(.INVOKEKIND = 1&, "VbMethod", .INVOKEKIND = 2&, "VbGet", .INVOKEKIND = 4&, "VbLet", .INVOKEKIND = 8&, "VbSet")
tFuncDescArray(n).ParamsCount = .cParams
tFuncDescArray(n).OptParamsCount = .cParamsOpt
tFuncDescArray(n).ReturnType = ReturnType(.elemdescFunc.tdesc.vt)
n = n + 1&
End If
End With
NextFunc:
If lFuncsCount Mod 100& = 0& Then DoEvents
Next
GetFuncs = tFuncDescArray
End If
End Function
Function MembersFromEnum(pEnum As LongPtr) As ENUM_VALS()
Const S_OK = 0&, CC_STDCALL = 4&
Dim ppTypeAttr As LongPtr, pcNames As LongPtr
Dim tTYPEATTR As TYPEATTR, tVARDESC As VARDESC
Dim tDUMMYUNIONNAME As DUMMYUNIONNAME_TYPE, tLRG_INT As LARGE_INT
Dim pVARDESC As LongPtr, BstrName As String
Dim vRet() As ENUM_VALS
Dim i As Long, lRet As Long
lRet = vtblCall(pEnum, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(ppTypeAttr)) 'ITypeInfo::GetTypeAttr
If lRet <> S_OK Then
MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description."
Exit Function
End If
If ppTypeAttr = NULL_PTR Then Exit Function
Call CopyMemory(ByVal VarPtr(tTYPEATTR), ByVal ppTypeAttr, LenB(tTYPEATTR))
lRet = vtblCall(pEnum, 19& * PTR_LEN, vbEmpty, CC_STDCALL, ppTypeAttr) 'ITypeInfo::ReleaseTypeAttr
ReDim vRet(tTYPEATTR.cVars - 1&)
For i = 0& To tTYPEATTR.cVars - 1&
lRet = vtblCall(pEnum, 6& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pVARDESC)) 'ITypeInfo::GetVarDesc
If lRet <> S_OK Then
MsgBox "Unable to retrieves a VARDESC structure that describes the specified variable."
Exit Function
End If
Call CopyMemory(ByVal VarPtr(tVARDESC), ByVal pVARDESC, LenB(tVARDESC))
lRet = vtblCall(pEnum, 7& * PTR_LEN, vbLong, CC_STDCALL, tVARDESC.memid, VarPtr(BstrName), tTYPEATTR.cVars, VarPtr(pcNames)) 'ITypeInfo::GetNames
If lRet <> S_OK Then
MsgBox "Unable to retrieves the variable with the specified member ID or the name of the property or method."
Exit Function
End If
Call CopyMemory(tDUMMYUNIONNAME, ByVal tVARDESC.DUMMYUNIONNAME, Len(tDUMMYUNIONNAME))
Call CopyMemory(ByVal tLRG_INT, tDUMMYUNIONNAME.lpvarValue, PTR_LEN)
vRet(i).Name = BstrName
vRet(i).Value = tLRG_INT.LowPart
MembersFromEnum = vRet
Next i
End Function
Function BuildFuncInfoString(INFO As FUNC_INFO) As TEXT_STRUCT
Dim tString As TEXT_STRUCT
With tString
.Caption = _
"[Member Name:]" & vbLf & _
"[INVOKEKIND:]" & vbLf & _
"[memid:]" & vbLf & _
"[ParamsCount:]" & vbLf & _
"[Opt ParamsCount:]" & vbLf & _
"[Funckind:]" & vbLf & _
"[VTBLOffset:]" & vbLf & _
"[CallConvention:]" & vbLf & _
"[ReturnType:]"
.Value = _
INFO.Name & vbLf & _
INFO.INVOKEKIND & vbLf & _
INFO.memid & vbLf & _
INFO.ParamsCount & vbLf & _
INFO.OptParamsCount & vbLf & _
INFO.funckind & vbLf & _
Hex(INFO.VTBLOffset) & vbLf & _
INFO.CallConvention & vbLf & _
INFO.ReturnType
End With
BuildFuncInfoString = tString
End Function
Function BuildEnumInfoString(INFO As ENUM_VALS) As TEXT_STRUCT
Dim tString As TEXT_STRUCT
With tString
.Caption = _
"[Const Name:]" & vbLf & _
"[Value:]"
.Value = _
INFO.Name & vbLf & _
INFO.Value
End With
BuildEnumInfoString = tString
End Function
Function RefLibNameToFullPath(ByVal ReferenceLibName As String) As String
'[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
Dim oRef As VBIDE.Reference, oRefs As VBIDE.References, i As Integer
On Error Resume Next
Set oRefs = Application.VBE.ActiveVBProject.References
For Each oRef In oRefs
i = i + 1&
If LCase(oRef.Name) = LCase(ReferenceLibName) Then
RefLibNameToFullPath = oRef.FullPath: Exit For
End If
Next oRef
End Function
Function GetVBEReferencesList() As String()
'[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
Dim oRef As VBIDE.Reference, oRefs As VBIDE.References, i As Integer, tmpArray() As String
Set oRefs = Application.VBE.ActiveVBProject.References
For Each oRef In oRefs
ReDim Preserve tmpArray(i)
tmpArray(i) = oRef.Name: i = i + 1&
Next oRef
GetVBEReferencesList = tmpArray
End Function
Function GUIDFromLib(ByVal LibPathName As String) As String
'[ Requires References :: Visual Basic for Applications Extensibility And Trust access to Visual Basic Project ]
Dim oRef As VBIDE.Reference, oRefs As VBIDE.References
Set oRefs = Application.VBE.ActiveVBProject.References
On Error Resume Next
For Each oRef In oRefs
If oRef.FullPath = LibPathName Then
GUIDFromLib = oRef.GUID: Exit For
End If
Next oRef
End Function
Function GetSpecialEnum(sEnum As String) As Boolean
'Handle special vba constants not defined in the enumerations module.
Dim a() As Variant, v As Variant
a = Array("Constants", "KeyCodeConstants", "ColorConstants", "SystemColorConstants")
For Each v In a
If ChrW(&H25E5) & " " & v = sEnum Then
GetSpecialEnum = True: Exit Function
End If
Next v
End Function
Function BuildSpecailEnumValues(ByVal sEnum As String, Optional sPfx As String) As SPECIAL_ENUMS
Dim X() As String, y() As String
Select Case sEnum
Case ChrW(&H25E5) & " " & "Constants"
ReDim X(10): ReDim y(10)
X(0) = sPfx & "vbObjectError": y(0) = -2147221504
X(1) = sPfx & "vbNullString": y(1) = vbNullString
X(2) = sPfx & "vbNullChar": y(2) = vbNullChar
X(3) = sPfx & "vbCrLf": y(3) = vbCrLf
X(4) = sPfx & "vbNewLine": y(4) = vbNewLine
X(5) = sPfx & "vbCr": y(5) = vbCr
X(6) = sPfx & "vbLf": y(6) = vbLf
X(7) = sPfx & "vbBack": y(7) = vbBack
X(8) = sPfx & "vbFormFeed": y(8) = vbFormFeed
X(9) = sPfx & "vbTab": y(9) = vbTab
X(10) = sPfx & "vbVerticalTab": y(10) = vbVerticalTab
Case ChrW(&H25E5) & " " & "KeyCodeConstants"
ReDim X(98): ReDim y(98)
X(0) = sPfx & "vbKeyLButton": y(0) = 1
X(1) = sPfx & "vbKeyRButton": y(1) = 2
X(2) = sPfx & "vbKeyCancel": y(2) = 3
X(3) = sPfx & "vbKeyMButton": y(3) = 4
X(4) = sPfx & "vbKeyBack": y(4) = 8
X(5) = sPfx & "vbKeyTab": y(5) = 9
X(6) = sPfx & "vbKeyClear": y(6) = 12
X(7) = sPfx & "vbKeyReturn": y(7) = 13
X(8) = sPfx & "vbKeyShift": y(8) = 16
X(9) = sPfx & "vbKeyControl": y(9) = 17
X(10) = sPfx & "vbKeyMenu": y(10) = 18
X(11) = sPfx & "vbKeyPause": y(11) = 19
X(12) = sPfx & "vbKeyCapital": y(12) = 20
X(13) = sPfx & "vbKeyEscape": y(13) = 27
X(14) = sPfx & "vbKeySpace": y(14) = 32
X(15) = sPfx & "vbKeyPageUp": y(15) = 33
X(16) = sPfx & "vbKeyPageDown": y(16) = 34
X(17) = sPfx & "vbKeyEnd": y(17) = 35
X(18) = sPfx & "vbKeyHome": y(18) = 36
X(19) = sPfx & "vbKeyLeft": y(19) = 37
X(20) = sPfx & "vbKeyUp": y(20) = 38
X(21) = sPfx & "vbKeyRight": y(21) = 39
X(22) = sPfx & "vbKeyDown": y(22) = 40
X(23) = sPfx & "vbKeySelect": y(23) = 41
X(24) = sPfx & "vbKeyPrint": y(24) = 42
X(25) = sPfx & "vbKeyExecute": y(25) = 43
X(26) = sPfx & "vbKeySnapshot": y(26) = 44
X(27) = sPfx & "vbKeyInsert": y(27) = 45
X(28) = sPfx & "vbKeyDelete": y(28) = 46
X(29) = sPfx & "vbKeyHelp": y(29) = 47
X(30) = sPfx & "vbKeyNumlock": y(30) = 144
X(31) = sPfx & "vbKeyA": y(31) = 65
X(32) = sPfx & "vbKeyB": y(32) = 66
X(33) = sPfx & "vbKeyC": y(33) = 67
X(34) = sPfx & "vbKeyD": y(34) = 68
X(35) = sPfx & "vbKeyE": y(35) = 69
X(36) = sPfx & "vbKeyF": y(36) = 70
X(37) = sPfx & "vbKeyG": y(37) = 71
X(38) = sPfx & "vbKeyH": y(38) = 72
X(39) = sPfx & "vbKeyI": y(39) = 73
X(40) = sPfx & "vbKeyJ": y(40) = 74
X(41) = sPfx & "vbKeyK": y(41) = 75
X(42) = sPfx & "vbKeyL": y(42) = 76
X(43) = sPfx & "vbKeyM": y(43) = 77
X(44) = sPfx & "vbKeyN": y(44) = 78
X(45) = sPfx & "vbKeyO": y(45) = 79
X(46) = sPfx & "vbKeyP": y(46) = 80
X(47) = sPfx & "vbKeyQ": y(47) = 81
X(48) = sPfx & "vbKeyR": y(48) = 82
X(49) = sPfx & "vbKeyS": y(49) = 83
X(50) = sPfx & "vbKeyT": y(50) = 84
X(51) = sPfx & "vbKeyU": y(51) = 85
X(52) = sPfx & "vbKeyV": y(52) = 86
X(53) = sPfx & "vbKeyW": y(53) = 87
X(54) = sPfx & "vbKeyX": y(54) = 88
X(55) = sPfx & "vbKeyY": y(55) = 89
X(56) = sPfx & "vbKeyZ": y(56) = 90
X(57) = sPfx & "vbKey0": y(57) = 48
X(58) = sPfx & "vbKey1": y(58) = 49
X(59) = sPfx & "vbKey2": y(59) = 50
X(60) = sPfx & "vbKey3": y(60) = 51
X(61) = sPfx & "vbKey4": y(61) = 52
X(62) = sPfx & "vbKey5": y(62) = 53
X(63) = sPfx & "vbKey6": y(63) = 54
X(64) = sPfx & "vbKey7": y(64) = 55
X(65) = sPfx & "vbKey8": y(65) = 56
X(66) = sPfx & "vbKey9": y(66) = 57
X(67) = sPfx & "vbKeyNumpad0": y(67) = 96
X(68) = sPfx & "vbKeyNumpad1": y(68) = 97
X(69) = sPfx & "vbKeyNumpad2": y(69) = 98
X(70) = sPfx & "vbKeyNumpad3": y(70) = 99
X(71) = sPfx & "vbKeyNumpad4": y(71) = 100
X(72) = sPfx & "vbKeyNumpad5": y(72) = 101
X(73) = sPfx & "vbKeyNumpad6": y(73) = 102
X(74) = sPfx & "vbKeyNumpad7": y(74) = 103
X(75) = sPfx & "vbKeyNumpad8": y(75) = 104
X(76) = sPfx & "vbKeyNumpad9": y(76) = 105
X(77) = sPfx & "vbKeyMultiply": y(77) = 106
X(78) = sPfx & "vbKeyAdd": y(78) = 107
X(79) = sPfx & "vbKeySeparator": y(79) = 108
X(80) = sPfx & "vbKeySubtract": y(80) = 109
X(81) = sPfx & "vbKeyDecimal": y(81) = 110
X(82) = sPfx & "vbKeyDivide": y(82) = 111
X(83) = sPfx & "vbKeyF1": y(83) = 112
X(84) = sPfx & "vbKeyF2": y(84) = 113
X(85) = sPfx & "vbKeyF3": y(85) = 114
X(86) = sPfx & "vbKeyF4": y(86) = 115
X(87) = sPfx & "vbKeyF5": y(87) = 116
X(88) = sPfx & "vbKeyF6": y(88) = 117
X(89) = sPfx & "vbKeyF7": y(89) = 118
X(90) = sPfx & "vbKeyF8": y(90) = 119
X(91) = sPfx & "vbKeyF9": y(91) = 120
X(92) = sPfx & "vbKeyF10": y(92) = 121
X(93) = sPfx & "vbKeyF11": y(93) = 122
X(94) = sPfx & "vbKeyF12": y(94) = 123
X(95) = sPfx & "vbKeyF13": y(95) = 124
X(96) = sPfx & "vbKeyF14": y(96) = 125
X(97) = sPfx & "vbKeyF15": y(97) = 126
X(98) = sPfx & "vbKeyF16": y(98) = 127
Case ChrW(&H25E5) & " " & "ColorConstants"
ReDim X(7): ReDim y(7)
X(0) = sPfx & "vbBlack": y(0) = 0
X(1) = sPfx & "vbRed": y(1) = 255
X(2) = sPfx & "vbGreen": y(2) = 65280
X(3) = sPfx & "vbYellow": y(3) = 65535
X(4) = sPfx & "vbBlue": y(4) = 16711680
X(5) = sPfx & "vbMagenta": y(5) = 16711935
X(6) = sPfx & "vbCyan": y(6) = 16776960
X(7) = sPfx & "vbWhite": y(7) = 16777215
Case ChrW(&H25E5) & " " & "SystemColorConstants"
ReDim X(28): ReDim y(28)
X(0) = sPfx & "vbScrollBars": y(0) = -2147483648#
X(1) = sPfx & "vbDesktop": y(1) = -2147483647
X(2) = sPfx & "vbActiveTitleBar": y(2) = -2147483646
X(3) = "vbInactiveTitleBar": y(3) = -2147483645
X(4) = sPfx & "vbMenuBar": y(4) = -2147483644
X(5) = sPfx & "vbWindowBackground": y(5) = -2147483643
X(6) = sPfx & "vbWindowFrame": y(6) = -2147483642
X(7) = sPfx & "vbMenuText": y(7) = -2147483641
X(8) = sPfx & "vbWindowText": y(8) = -2147483640
X(9) = sPfx & "vbTitleBarText": y(9) = -2147483639
X(10) = sPfx & "vbActiveBorder": y(10) = -2147483638
X(11) = sPfx & "vbInactiveBorder": y(11) = -2147483637
X(12) = sPfx & "vbApplicationWorkspace": y(12) = -2147483636
X(13) = sPfx & "vbHighlight": y(13) = -2147483635
X(14) = sPfx & "vbHighlightText": y(14) = -2147483634
X(15) = sPfx & "vbButtonFace": y(15) = -2147483633
X(16) = sPfx & "vbButtonShadow": y(16) = -2147483632
X(17) = sPfx & "vbGrayText": y(17) = -2147483631
X(18) = sPfx & "vbButtonText": y(18) = -2147483630
X(19) = sPfx & "vbInactiveCaptionText": y(19) = -2147483629
X(20) = sPfx & "vb3DHighlight": y(20) = -2147483628
X(21) = sPfx & "vb3DFace": y(21) = -2147483633
X(22) = sPfx & "vbMsgBox": y(22) = -2147483625
X(23) = sPfx & "vbMsgBoxText": y(23) = -2147483624
X(24) = sPfx & "vb3DShadow": y(24) = -2147483632
X(25) = sPfx & "vb3DDKShadow": y(25) = -2147483627
X(26) = sPfx & "vb3DLight": y(26) = -2147483626
X(27) = sPfx & "vbInfoText": y(27) = -2147483625
X(28) = sPfx & "vbInfoBackground": y(28) = -2147483624
End Select
BuildSpecailEnumValues.Caption = X: BuildSpecailEnumValues.Value = y
End Function
Function GetModulesBaseNamesFromCurrentProcess() As String()
Const MAX_PATH = 1024&, MAX_NUM_OF_MODULES = 1024&, HANDLE_SIZE = PTR_LEN
Dim hModuleHandles(MAX_NUM_OF_MODULES) As LongPtr
Dim hProc As LongPtr
Dim sModName As String
Dim sModBaseName As String
Dim sModPath As String
Dim tModInfo As MODULEINFO
Dim lBytesNeeded As Long, lModCount As Long, i As Long, lStrLen As Long
hProc = GetCurrentProcess
If EnumProcessModules(hProc, hModuleHandles(0&), (MAX_NUM_OF_MODULES * HANDLE_SIZE), lBytesNeeded) = False Then
Debug.Print "EnumProcessModules failed"
Exit Function
End If
lModCount = lBytesNeeded \ HANDLE_SIZE
ReDim sModulesArray(lModCount) As String
For i = 0& To lModCount - 1&
If hModuleHandles(i) = 0& Then
GoTo skipModule
End If
If GetModuleInformation(hProc, hModuleHandles(i), tModInfo, lBytesNeeded) = 0& Then
GoTo skipModule
End If
sModName = Space(MAX_PATH + 1&)
lStrLen = GetModuleFileNameExW(hProc, hModuleHandles(i), StrPtr(sModName), Len(sModName))
sModPath = Mid(sModName, 1&, lStrLen)
lStrLen = GetModuleBaseNameW(hProc, hModuleHandles(i), StrPtr(sModName), Len(sModName))
sModBaseName = Mid(sModName, 1&, lStrLen)
sModulesArray(i) = sModBaseName
skipModule:
Next i
GetModulesBaseNamesFromCurrentProcess = sModulesArray
Erase hModuleHandles
Call CloseHandle(hProc)
End Function
Function ModuleBaseNameToFullPath(ByVal BaseName As String) As String
ModuleBaseNameToFullPath = ModuleFileName(BaseName)
End Function
' ______________________________________ PRIVATE SUBS _______________________________________________
Private Function InterFacesFromClass(tClass As INTERFACE_INFO) As INTERFACE_INFO()
Const S_OK = 0&, CC_STDCALL = 4&, MEMBERID_NIL = -1&
Dim pRefType As LongPtr, pClasstypeInfo As LongPtr, farPtr As LongPtr, psGUID As LongPtr
Dim tTYPEATTR As TYPEATTR, tInterfaceInfo As INTERFACE_INFO
Dim i As Long, lRet As Long, lInterfaceCount As Long
Dim sInterfaceName As String
lInterfaceCount = tClass.InterfacesCount
ReDim ar(lInterfaceCount - 1&) As INTERFACE_INFO
With tClass
For i = 0& To .InterfacesCount - 1&
lRet = vtblCall(.ptr, 8& * PTR_LEN, vbLong, CC_STDCALL, i, VarPtr(pRefType)) 'ITypeInfo::GetRefTypeOfImplType
If lRet <> S_OK Then
MsgBox "Unable to retrieve the type description of the implemented interface type.": Exit Function
End If
lRet = vtblCall(.ptr, 14& * PTR_LEN, vbLong, CC_STDCALL, pRefType, VarPtr(pClasstypeInfo)) 'ITypeInfo::GetRefTypeInfo
If lRet <> S_OK Then
MsgBox "Unable to retrieve the referenced type descriptions.": Exit Function
End If
lRet = vtblCall(pClasstypeInfo, 12& * PTR_LEN, vbLong, CC_STDCALL, MEMBERID_NIL, VarPtr(sInterfaceName), NULL_PTR, NULL_PTR, NULL_PTR) 'ITypeInfo::GetDocumentation
If lRet <> S_OK Then
MsgBox "Unable to retrieve the documentation string.": Exit Function
End If
lRet = vtblCall(pClasstypeInfo, 3& * PTR_LEN, vbLong, CC_STDCALL, VarPtr(farPtr)) 'ITypeInfo::GetTypeAttr
If lRet <> S_OK Then
MsgBox "Unable to retrieve a TYPEATTR structure that contains the attributes of the type description"
Exit Function
End If
Call CopyMemory(tTYPEATTR, ByVal farPtr, LenB(tTYPEATTR))
lRet = vtblCall(pClasstypeInfo, 19& * PTR_LEN, vbEmpty, CC_STDCALL, farPtr) 'ITypeInfo::ReleaseTypeAttr
Call StringFromIID(tTYPEATTR.aGUID, VarPtr(psGUID))
With tInterfaceInfo
.ptr = pClasstypeInfo
.GUID = GetStrFromPtrW(psGUID)
.Name = sInterfaceName
.MembersCount = tTYPEATTR.cFuncs
.wMajorVerNum = tTYPEATTR.wMajorVerNum
.wMinorVerNum = tTYPEATTR.wMinorVerNum
End With
ar(i) = tInterfaceInfo
Next i
End With
InterFacesFromClass = ar
End Function
Private Function vtblCall( _
ByVal InterfacePointer As LongPtr, _
ByVal VTableOffset As Long, _
ByVal FunctionReturnType As Long, _
ByVal CallConvention As Long, _
ParamArray FunctionParameters() As Variant _
) As Variant
Dim vParamPtr() As LongPtr
If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function
Dim pIndex As Long, pCount As Long
Dim vParamType() As Integer
Dim vRtn As Variant, vParams() As Variant
vParams() = FunctionParameters()
pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
If pCount = 0& Then
ReDim vParamPtr(0& To 0&)
ReDim vParamType(0& To 0&)
Else
ReDim vParamPtr(0& To pCount - 1&)
ReDim vParamType(0& To pCount - 1&)
For pIndex = 0& To pCount - 1&
vParamPtr(pIndex) = VarPtr(vParams(pIndex))
vParamType(pIndex) = VarType(vParams(pIndex))
Next
End If
pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, vParamType(0&), vParamPtr(0&), vRtn)
If pIndex = 0& Then
vtblCall = vRtn
Else
SetLastError pIndex
End If
End Function
Private Function BuildClassInfoString(INFO As INTERFACE_INFO, bShowUnkDisp As Boolean) As TEXT_STRUCT
Dim tString As TEXT_STRUCT
With tString
.Caption = _
"[Class Name:] " & vbLf & _
"[Members Count:] " & vbLf & _
"[GUID:] " & vbLf & _
"[LCID:] " & vbLf & _
"[PTR:] "
.Value = INFO.Name & vbLf & _
IIf(bShowUnkDisp, INFO.MembersCount, INFO.MembersCount - 7&) & vbLf & _
INFO.GUID & vbLf & _
INFO.lcid & vbLf & _
INFO.ptr
End With
BuildClassInfoString = tString
End Function
Private Function ReturnType(ByVal RetType As VarEnum) As String
Dim sRetVarType As String
Select Case RetType
Case VT_NULL: sRetVarType = "Long"
Case VT_I2: sRetVarType = "Integer"
Case VT_I4: sRetVarType = "Long"
Case VT_R4: sRetVarType = "Single"
Case VT_R8: sRetVarType = "Double"
Case VT_CY: sRetVarType = "Currency"
Case VT_DATE: sRetVarType = "Date"
Case VT_BSTR: sRetVarType = "BSTR(String)"
Case VT_DISPATCH, VT_PTR: sRetVarType = "Object"
Case VT_ERROR: sRetVarType = "SCODE"
Case VT_BOOL: sRetVarType = "Boolean"
Case VT_VARIANT: sRetVarType = "VARIANT"
Case VT_UNKNOWN: sRetVarType = "IUnknown*"
Case VT_UI1: sRetVarType = "Byte"
Case VT_DECIMAL: sRetVarType = "Decimal"
Case VT_I1: sRetVarType = "Char"
Case VT_UI2: sRetVarType = "USHORT"
Case VT_UI4: sRetVarType = "ULONG"
Case VT_I8: sRetVarType = "LongLong"
Case VT_UI8: sRetVarType = "unsigned __int64"
Case VT_INT: sRetVarType = "int"
Case VT_UINT: sRetVarType = "UINT"
Case VT_HRESULT: sRetVarType = "HRESULT"
Case VT_VOID: sRetVarType = "VOID"
Case VT_LPSTR: sRetVarType = "char*"
Case VT_LPWSTR: sRetVarType = "wchar_t*"
Case Else: sRetVarType = "ANY"
End Select
ReturnType = sRetVarType
End Function
Private Function GetStrFromPtrW(ByVal lpString As LongPtr) As String
Call SysReAllocString(VarPtr(GetStrFromPtrW), lpString)
Call CoTaskMemFree(lpString)
End Function
Private Function ModuleFileName(ByVal ModuleName As String) As String
Const MAX_PATH = 1024&
Dim sBuffer As String, lRet As Long, hMod As LongPtr
hMod = GetModuleHandleW(StrPtr(ModuleName))
sBuffer = Space(MAX_PATH)
lRet = GetModuleFileNameW(hMod, StrPtr(sBuffer), Len(sBuffer))
ModuleFileName = Left(sBuffer, lRet)
End Function