The making of a type library browser

[José Roca]

Type libraries contain the specification for one or more COM elements, including classes, interfaces, enumerations, and more. These files are stored in a standard binary format. A type library can be a stand-alone file with the .tlb file name extension, or it can be stored as a resource in an executable file, which can have an .ocx, .dll, or .exe file name extension. The type library viewers and conversion tools described following read this format to gain information about the COM elements in the library.

Before you can program an object in a particular programming language, you must be able to view its type library in that language. Doing this provides you with the proper syntax for the classes, interfaces, methods, properties, and events of the COM object.

https://msdn.microsoft.com/en-us/library/windows/desktop/ms680581(v=vs.85).aspx

Microsoft provides an OLE-COM Viewer, Oleview.exe, an application supplied with Visual C++ that displays the COM objects installed on your computer and the interfaces they support. You can use this object viewer to view type libraries. Visual Basic 6 has its own object browser.

What we need is a type library browser able to generate code in the proper syntax to be used with Free Basic.

[José Roca]

The first step is to retrieve the type libraries registered in the system.

All the registered type libraries have an entry in the registry under HKEY_CLASSES_ROOT\TypeLib. Under this section, every subkey is the CLSID of a TypeLibrary. Under the CLSID subkey there are one or more subkeys with the version numbers, that generally take the format MajorVersion.MinorVersion (e.g.: 1.0). Opening these version subkeys, there are other subkeys. The one that we need is the default one (0), which can contain one or two subkeys, "win32" and/or "win64". Opening these subkeys we can retrieve the path of the type library.

Code Select Expand


' ########################################################################################
' TypeLib Browser
' File: TLB_ENUMTLBS.INC
' Contents: TypeLib Browser typelibs enumeration
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

' ========================================================================================
' Searches for the win32 subkey
' ========================================================================================
FUNCTION TLB_RegSearchWin32 (BYVAL pwszKey AS WSTRING PTR) AS CWSTR

   IF pwszKey = NULL THEN RETURN ""

   ' // Recursively searches for the win directory
   DIM hr AS LONG, hKey AS HKEY, dwIdx AS DWORD, ft AS FILETIME
   DIM wszKeyName AS WSTRING * MAX_PATH, wszClass AS WSTRING * MAX_PATH
   DIM cchName AS DWORD = MAX_PATH, cchClass AS DWORD = MAX_PATH
   DIM wszKey AS WSTRING * MAX_PATH = *pwszKey
   DO
      wszKeyName = "" : cchName = MAX_PATH : wszClass = "" : cchClass = MAX_PATH
      hr = RegOpenKeyExW (HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
      IF hr <> ERROR_SUCCESS THEN RETURN ""
      IF hKey = NULL THEN RETURN ""
      hr = RegEnumKeyExW(hKey, dwIdx, @wszKeyName, @cchName, 0, @wszClass, @cchClass, @ft)
      IF hr <> S_OK THEN EXIT DO
      IF UCASE(wszKeyName) = "WIN32" THEN EXIT DO
      dwIdx += 1
   LOOP WHILE hr = S_OK

   ' // Closes the registry and returns the result
   RegCloseKey hKey
   IF hr <> S_OK OR LEN(wszKeyName) = 0 THEN RETURN ""
   RETURN wszKey

END FUNCTION
' ========================================================================================

' ========================================================================================
' Searches for the win64 subkey
' ========================================================================================
FUNCTION TLB_RegSearchWin64 (BYVAL pwszKey AS WSTRING PTR) AS CWSTR

   IF pwszKey = NULL THEN RETURN ""

   ' // Recursively searches for the win directory
   DIM hr AS LONG, hKey AS HKEY, dwIdx AS DWORD, ft AS FILETIME
   DIM wszKeyName AS WSTRING * MAX_PATH, wszClass AS WSTRING * MAX_PATH
   DIM cchName AS DWORD = MAX_PATH, cchClass AS DWORD = MAX_PATH
   DIM wszKey AS WSTRING * MAX_PATH = *pwszKey
   DO
      wszKeyName = "" : cchName = MAX_PATH : wszClass = "" : cchClass = MAX_PATH
      hr = RegOpenKeyExW (HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
      IF hr <> ERROR_SUCCESS THEN RETURN ""
      IF hKey = NULL THEN RETURN ""
      hr = RegEnumKeyExW(hKey, dwIdx, @wszKeyName, @cchName, 0, @wszClass, @cchClass, @ft)
      IF hr <> S_OK THEN EXIT DO
      IF UCASE(wszKeyName) = "WIN64" THEN EXIT DO
      dwIdx += 1
   LOOP WHILE hr = S_OK

   ' // Closes the registry and returns the result
   RegCloseKey hKey
   IF hr <> S_OK OR LEN(wszKeyName) = 0 THEN RETURN ""
   RETURN wszKey

END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the path of the typelib.
' ========================================================================================
FUNCTION TLB_RegEnumDirectory (BYVAL pwszKey AS WSTRING PTR) AS CWSTR

   IF pwszKey = NULL THEN RETURN ""

   ' // Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
   DIM hKey AS HKEY, wszKey AS WSTRING * MAX_PATH = *pwszKey
   DIM hr AS LONG = RegOpenKeyExW(HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
   IF hr <> ERROR_SUCCESS THEN RETURN ""
   IF hKey = 0 THEN RETURN ""
   DIM dwIdx AS DWORD, wszKeyName AS WSTRING * MAX_PATH, wszClass AS WSTRING * MAX_PATH, ft AS FILETIME
   DIM cchName AS DWORD = MAX_PATH, cchClass AS DWORD = MAX_PATH, wszSubkey AS WSTRING * MAX_PATH
   DO
      wszKeyName = "" : cchName = MAX_PATH : wszClass = "" : cchClass = MAX_PATH
      hr = RegEnumKeyExW(hKey, dwIdx, @wszKeyName, @cchName, 0, @wszClass, @cchClass, @ft)
      IF hr <> S_OK THEN EXIT DO
#ifdef __FB_64BIT__
      wszSubkey = TLB_RegSearchWin64(wszKey & "\" & wszKeyName)
      IF LEN(wszSubkey) THEN wszKey = wszSubkey & "\" & "win64"
#else
      wszSubkey = TLB_RegSearchWin32(wszKey & "\" & wszKeyName)
      IF LEN(wszSubkey) THEN wszKey = wszSubkey & "\" & "win32"
#endif
#ifdef __FB_64BIT__
      ' // Not all the typelibs have separate entries in the win64 subkey
      ' // See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms724072(v=vs.85).aspx
      ' // If not found in the win64 subkey search in the win32 subkey
      IF LEN(wszSubkey) = 0 THEN wszSubkey = TLB_RegSearchWin32(wszKey & "\" & wszKeyName)
      IF LEN(wszSubkey) THEN wszKey = wszSubkey & "\" & "win32"
#endif
      IF LEN(wszSubkey) THEN EXIT DO
      dwIdx += 1
   LOOP
   RegCloseKey hKey
   IF hr <> S_OK OR LEN(wszSubkey) = 0 THEN RETURN ""

   hKey = NULL
   hr = RegOpenKeyExW(HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
   IF hr <> ERROR_SUCCESS THEN RETURN ""
   DIM keyType AS DWORD
   DIM wszValueName AS WSTRING * MAX_PATH
   DIM wszKeyValue  AS WSTRING * MAX_PATH
   DIM cValueName AS DWORD = MAX_PATH
   DIM cbData AS DWORD = MAX_PATH
   dwIdx = 0
   hr = RegEnumValueW(hKey, dwIdx, @wszValueName, @cValueName, NULL, @keyType, cast(BYTE PTR, @wszKeyValue), @cbData)

   ' // Closes the registry and returns the value
   RegCloseKey hKey
   RETURN wszKeyValue

END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the different versions of the typelib.
' Parameter
' - hListView = Handle of the list view.
' - pwszLibId = Library guid.
' Return value: TRUE or FALSE.
' ========================================================================================
FUNCTION TLB_RegEnumVersions (BYVAL hListView AS HWND, BYVAL pwszLibId AS WSTRING PTR) AS BOOLEAN

   IF hListView = NULL OR pwszLibId = NULL THEN EXIT FUNCTION

   ' // Searches the HKEY_CLASSES_ROOT\TypeLib\<LIBID> node.
   DIM hKey AS HKEY
   DIM wszKey AS WSTRING * MAX_PATH = "TypeLib\" & *pwszLibId
   DIM hr AS LONG = RegOpenKeyExW(HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
   IF hr <> ERROR_SUCCESS THEN RETURN FALSE
   IF hKey = NULL THEN RETURN FALSE

   ' // Opens the subtrees of the different versions of the TyleLib library
   DIM dwIdx AS DWORD, wszKeyName AS WSTRING * MAX_PATH, wszClass AS WSTRING * MAX_PATH, ft AS FILETIME
   DIM cchName AS DWORD = MAX_PATH, cchClass AS DWORD = MAX_PATH
   DO
      wszKeyName = "" : cchName = MAX_PATH : wszClass = "" : cchClass = MAX_PATH
      DIM hr AS LONG = RegEnumKeyExW(hKey, dwIdx, @wszKeyName, @cchName, 0, @wszClass, @cchClass, @ft)
      IF hr <> ERROR_SUCCESS THEN RETURN FALSE
      ' // Gets the default value
      DIM hVerKey AS HKEY, wszSubKey AS WSTRING * MAX_PATH = wszKey & "\" & wszKeyName
      hr = RegOpenKeyExW(HKEY_CLASSES_ROOT, @wszSubKey, 0, KEY_READ, @hVerKey)
      IF hr <> ERROR_SUCCESS THEN RETURN FALSE
      DIM wszVer AS WSTRING * MAX_PATH = wszKeyName
      ' // Enumerate the entries until the default one, if any, is found.
      ' // RegEnumValue returns values in any order. This includes unnamed values.
      ' // A key may have one unnamed value. An unnamed value is displayed as (Default)
      ' // in Regedit.exe. If an unnamed value doesn't exist under a given key, it is
      ' // displayed as (value not set) in Regedit.exe.
      ' // Only existing unnamed values can be enumerated. If an unnamed value is enumerated, the
      ' // RegEnumValue function sets wszValueName to an empty string ("") and it sets cValueName to 0.
      DIM verIdx AS DWORD, cValueName AS DWORD, cbData AS DWORD, keyType AS DWORD
      DIM wszValueName AS WSTRING * 16383, wszKeyValue AS WSTRING * MAX_PATH
      DO
         cValueName = 16383 : cbData = MAX_PATH * 2 : wszValueName = "" : wszKeyValue = ""
         hr = RegEnumValueW(hVerKey, verIdx, @wszValueName, @cValueName, NULL, @keyType, cast(BYTE PTR, @wszKeyValue), @cbData)
         IF LEN(wszValueName) = 0 THEN EXIT DO   ' // This is the default, unnamed value
         IF hr <> ERROR_SUCCESS THEN EXIT DO
         ' // Increment the index of the value to be retrieved.
         verIdx += 1
      LOOP
      ' // Closes the handle of the registry key
      RegCloseKey hVerKey
      DIM wszDesc AS WSTRING * MAX_PATH
      ' // If wszValueName is an empty string, assume that the value name is the key value.
      IF LEN(wszValueName) = 0 THEN wszDesc = wszKeyValue ELSE wszDesc = wszValueName
      ' // Increment the index of the subkey
      dwIdx += 1
      ' // Find the path of the type library
      DIM wszPath AS WSTRING * MAX_PATH = TLB_RegEnumDirectory(wszKey & "\" & wszKeyName)
'      ' // If there is not path, skip the typelib because we can't retrieve it
      IF LEN(wszPath) = 0 THEN CONTINUE DO
'      ' // Remove double quotes (if any)
      wszPath = AfxStrRemove(wszPath, """")
'      ' // Convert short paths to long paths
'      ' // Dont use it with all files or these ending with version numbers
'      ' // (a \ and a number) will we skipped.
      IF INSTR(wszPath, "%") THEN
         DIM wszDest AS WSTRING * MAX_PATH, cbLen AS DWORD
         cbLen = ExpandEnvironmentStringsW(@wszPath, @wszDest, MAX_PATH)
         IF cbLen THEN wszPath = wszDest
      END IF
      IF INSTR(wszPath, "~") <> 0 THEN
         DIM cbPath AS DWORD = LEN(wszPath)
         cbPath = GetLongPathNameW(wszPath, wszPath, cbPath)
      END IF
      DIM pathPos AS LONG = INSTRREV(wszPath, "\")
      DIM wszFile AS WSTRING * MAX_PATH = MID(wszPath, pathPos + 1)
      ' // Some have an added backslah and a number
      IF INSTR(wszFile, ".") = 0 THEN
         DIM wszTmpPath AS WSTRING * MAX_PATH = LEFT(wszPath, pathpos - 1)
         pathPos = INSTRREV(wszTmpPath, "\")
         wszFile = MID(wszTmpPath, pathPos + 1)
      END IF
      IF LEN(wszFile) = 0 THEN CONTINUE DO  ' // Skip files without a full path
      ' // Skip .OCA files
      DIM wszTemp AS WSTRING * MAX_PATH = wszPath
      IF MID(wszTemp, LEN(wszTemp) - 2, 1) = "\" THEN wszTemp = LEFT(wszTemp, LEN(wszTemp) - 2)
      IF MID(wszTemp, LEN(wszTemp) - 3, 1) = "\" THEN wszTemp = LEFT(wszTemp, LEN(wszTemp) - 3)
      ' // .OCA files are created by Visual Basic (we don't need them)
      IF UCASE(RIGHT(wszTemp, 4)) = ".OCA" THEN wszPath = ""
      IF LEN(wszPath) THEN
         ' // If the description is empty, use the file name
         IF wszDesc = "" THEN wszDesc = "[" & wszFile & "]"
         ' // Add the version number
         wszDesc += " (Ver " & wszVer & ")"
         ' // Add the items ro the list view
         DIM lItemIdx AS LONG = ListView_AddItem(hListView, 0, 0, @wszFile)
         ListView_SetItemText(hListView, lItemIdx, 1, @wszDesc)
         ListView_SetItemText(hListView, lItemIdx, 2, @wszPath)
         ListView_SetItemText(hListView, lItemIdx, 3, pwszLibId)
      END IF
   LOOP

   ' // Closes the registry key
   RegCloseKey hKey

END FUNCTION
' ========================================================================================

' ========================================================================================
' Enumerates all the typelibs.
' Parameter
' - hListView = Handle of the list view.
' Return value: TRUE or FALSE.
' ========================================================================================
FUNCTION TLB_RegEnumTypeLibs (BYVAL hListView AS HWND) AS BOOLEAN

   IF hListView = NULL THEN RETURN FALSE

   ' // Opens the HKEY_CLASSES_ROOT\TypeLib subtree
   DIM hKey AS HKEY
   DIM wszKey AS WSTRING * MAX_PATH = "TypeLib"
   DIM hr AS LONG = RegOpenKeyExW(HKEY_CLASSES_ROOT, @wszKey, 0, KEY_READ, @hKey)
   IF hr <> ERROR_SUCCESS THEN RETURN FALSE
   IF hKey = NULL THEN RETURN FALSE

   ' // Parses all the TypeLib subtree and gets the CLSIDs of all the TypeLibs
   DIM dwIdx AS DWORD, wszKeyName AS WSTRING * MAX_PATH, wszClass AS WSTRING * MAX_PATH, ft AS FILETIME
   DIM cchName AS DWORD = MAX_PATH, cchClass AS DWORD = MAX_PATH
   DO
      wszKeyName = "" : cchName = MAX_PATH : wszClass = "" : cchClass = MAX_PATH
      hr = RegEnumKeyExW(hKey, dwIdx, @wszKeyName, @cchName, 0, @wszClass, @cchClass, @ft)
      IF hr <> ERROR_SUCCESS THEN EXIT DO
      TLB_RegEnumVersions hListView, @wszKeyName
      dwIdx += 1
   LOOP
   ' // Closes the registry
   RegCloseKey hKey

   RETURN TRUE

END FUNCTION
' ========================================================================================


[José Roca]

Once we have retrieved the path of the type library, the next step if to load it calling the API functions LoadTypelib or LoadTpeLibEx, that return a pointer of the ITypeLib interface.

This is my definition of that interface:

Code Select Expand


' ########################################################################################
' Interface name = ITypeLib
' Extracts information about a type library, the data that describes a set of objects.
' Inherited interface = IUnknown
' ########################################################################################

#ifndef __Afx_ITypeLib_INTERFACE_DEFINED__
#define __Afx_ITypeLib_INTERFACE_DEFINED__

TYPE Afx_ITypeLib_ EXTENDS Afx_IUnknown
   DECLARE ABSTRACT FUNCTION GetTypeInfoCount () AS UINT
   DECLARE ABSTRACT FUNCTION GetTypeInfo (BYVAL index AS UINT, BYVAL ppTInfo AS Afx_ITypeInfo PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetTypeInfoType (BYVAL index AS UINT, BYVAL pTKind AS TYPEKIND PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetTypeInfoOfGuid (BYVAL guid AS CONST GUID CONST PTR, BYVAL ppTinfo AS Afx_ITypeInfo PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetLibAttr (BYVAL ppTLibAttr AS TLIBATTR PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetTypeComp (BYVAL ppTComp AS ITypeComp PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetDocumentation (BYVAL index AS INT_, BYVAL pBstrName AS AFX_BSTR PTR, BYVAL pBstrDocString AS AFX_BSTR PTR, BYVAL pdwHelpContext AS DWORD PTR, BYVAL pBstrHelpFile AS AFX_BSTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION IsName (BYVAL szNameBuf AS LPOLESTR, BYVAL lHashVal AS ULONG, BYVAL pfName AS WINBOOL PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION FindName (BYVAL szNameBuf AS LPOLESTR, BYVAL lHashVal AS ULONG, BYVAL ppTInfo AS Afx_ITypeInfo PTR PTR, BYVAL rgMemId AS MEMBERID PTR, BYVAL pcFound AS USHORT PTR) AS HRESULT
   DECLARE ABSTRACT SUB      ReleaseTLibAttr (BYVAL pTLibAttr AS TLIBATTR PTR)
END TYPE

#endif


and this is some code to load the type library and extract basic information:

Code Select Expand


' =====================================================================================
' Load the type library
' =====================================================================================
FUNCTION CParseTypeLib.LoadTypeLibEx (BYVAL pwszPath AS WSTRING PTR) AS HRESULT

   DIM hr AS HRESULT

   DIM pTypeLib AS ITypeLib PTR
   hr = .LoadTypeLibEx(pwszPath, REGKIND_NONE, @pTypeLib)
   m_pTypeLib = cast(Afx_ITypeLib PTR, cast(ULONG_PTR, pTypeLib))
   IF hr <> S_OK OR m_pTypeLib = NULL THEN
      TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX(hr, 8) & " loading " & *pwszPath, _
         MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.LoadTypeLibEx"
      RETURN hr
   END IF
   m_LibPath = *pwszPath

   ' // Gets the documentation
   DIM AS CBSTR cbsLibName, cbsLibHelpString, cbsLibHelpFile
   hr = m_pTypeLib->GetDocumentation(-1, @cbsLibName, @cbsLibHelpString, @m_LibHelpContext, @cbsLibHelpFile)
   m_LibName = cbsLibName : m_LibHelpString = cbsLibHelpString : m_LibHelpFile = cbsLibHelpFile
   IF hr <> S_OK THEN
      TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX(hr, 8) & " retrieving the documentation", _
         MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.LoadTypeLibEx"
      RETURN hr
   END IF
   ' // Use the library name as a prefix
   m_PrefixStr = TRIM(m_LibName, ANY CHR(32, 34))
   DIM hEditPrefix AS HWND = cast(HWND, m_pWindow->UserData(AFX_HEDITPREFIX))
   SetWindowText hEditPrefix, m_PrefixStr

   ' // Gets the attributes of the library
   DIM pLibAttr AS TLIBATTR PTR
   hr = m_pTypeLib->GetLibAttr(@pLibAttr)
   IF hr <> S_OK OR pLibAttr = NULL THEN
      TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX(hr, 8) & " retrieving the attributes", _
         MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.LoadTypeLibEx"
      RETURN hr
   END IF
   m_LibGuid = AfxGuidText(pLibAttr->guid)
   m_LibLcid = pLibAttr->lcid
   m_LibSysKind = pLibAttr->syskind
   m_LibMajorVersion = pLibAttr->wMajorVerNum
   m_LibMinorVersion = pLibAttr->wMinorVerNum
   m_LibAttr = pLibAttr->wLibFlags
   m_pTypeLib->ReleaseTLibAttr(pLibAttr)

   ' // Treeview handle
   DIM hTreeView AS HWND = cast(HWND, m_pWindow->UserData(AFX_HTREEVIEW))
   ' // Delete all the items in the tree view
   TreeView_DeleteAllItems(hTreeView)
   ' // Create the nodes
   m_hRootNode = TreeView_AddItem(hTreeView, 0, TVI_ROOT, m_LibName)
   m_hDocNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Documentation")
   m_hProgIDsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "ProgIDs (Program identifiers)")
   m_hVerIndProgIDsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Version independent ProgIDs")
   m_hClsIDsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "ClsIDs (Class identifiers)")
   m_hIIDsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "IIDs (Interface identifiers)")
   m_hCoClassesNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "CoClasses")
   m_hTypeDefsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Typedefs")
   m_hAliasesNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Aliases")
   m_hEnumsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Enumerations")
   m_hRecordsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Structures")
   m_hUnionsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Unions")
   m_hModulesNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Modules")
   m_hIntNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Interfaces")
   m_hOleAutIntNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Ole automation interfaces")
   m_hDualIntNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Dual interfaces")
   m_hDispIntNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Dispatch interfaces")
   m_hDispblIntNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Dispatchable interfaces")
   m_hEventsNode = TreeView_AddItem(hTreeView, m_hRootNode, NULL, "Events interfaces")
   ' // Fill the documentation node
   IF m_hDocNode THEN
      IF LEN(m_LibHelpString) THEN TreeView_AddItem hTreeView, m_hDocNode, NULL, "Help string = " & m_LibHelpString
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "GUID = " & m_LibGuid
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "LCID = " & WSTR(m_LibLcid)
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "Major version = " & WSTR(m_LibMajorVersion)
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "Minor version = " & WSTR(m_LibMinorVersion)
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "Path = " & m_LibPath
      IF m_LibHelpContext THEN TreeView_AddItem hTreeView, m_hDocNode, NULL, "Help context = " & WSTR(m_LibHelpContext)
      IF LEN(m_LibHelpFile) THEN TreeView_AddItem hTreeView, m_hDocNode, NULL, "Help file = " & m_LibHelpFile
      TreeView_AddItem hTreeView, m_hDocNode, NULL, "Attributes = " & WSTR(m_LibAttr) & " [&H" & HEX(m_LibAttr, 8) & "] " & TLB_LibFlagsToStr(m_LibAttr)
      SELECT CASE m_LibSysKind
         CASE SYS_WIN16 : TreeView_AddItem hTreeView, m_hDocNode, NULL, "Target OS = " & WSTR(m_LibSysKind) & " (Win16)"
         CASE SYS_WIN32 : TreeView_AddItem hTreeView, m_hDocNode, NULL, "Target OS = " & WSTR(m_LibSysKind) & " (Win32)"
         CASE SYS_MAC   : TreeView_AddItem hTreeView, m_hDocNode, NULL, "Target OS = " & WSTR(m_LibSysKind) & " (MAC)"
         CASE SYS_WIN64 : TreeView_AddItem hTreeView, m_hDocNode, NULL, "Target OS = " & WSTR(m_LibSysKind) & " (Win64)"
      END SELECT
   END IF

   ' // Parse the type infos
   this.ParseTypeInfos

   ' // Expands the root node
   TreeView_Expand(hTreeView, m_hRootNode, TVE_EXPAND)

END FUNCTION
' =====================================================================================


[José Roca]

To parse the type library information we need to call the methods of the ITypeInfo interface.

This is the definition of that interface:

Code Select Expand


' ########################################################################################
' Interface name = ITypeInfo
' Extracts information about the characteristics and capabilities of objects from type libraries.
' Inherited interface = IUnknown
' ########################################################################################

TYPE Afx_ITypeInfo AS Afx_ITypeInfo_

#ifndef __Afx_ITypeInfo_INTERFACE_DEFINED__
#define __Afx_ITypeInfo_INTERFACE_DEFINED__

TYPE Afx_ITypeInfo_ EXTENDS Afx_IUnknown
   DECLARE ABSTRACT FUNCTION GetTypeAttr (BYVAL ppTypeAttr AS TYPEATTR PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetTypeComp (BYVAL ppTComp AS ITypeComp PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetFuncDesc (BYVAL index AS UINT, BYVAL ppFuncDesc AS FUNCDESC PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetVarDesc (BYVAL index AS UINT, BYVAL ppVarDesc AS VARDESC PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetNames (BYVAL memid AS MEMBERID, BYVAL rgBstrNames AS AFX_BSTR PTR, BYVAL cMaxNames AS UINT, BYVAL pcNames AS UINT PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetRefTypeOfImplType (BYVAL index AS UINT, BYVAL pRefType AS HREFTYPE PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetImplTypeFlags (BYVAL index AS UINT, BYVAL pImplTypeFlags AS INT_ PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetIDsOfNames (BYVAL rgszNames AS LPOLESTR PTR, BYVAL cNames AS UINT, BYVAL pMemId AS MEMBERID PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION Invoke (BYVAL pvInstance AS PVOID, BYVAL memid AS MEMBERID, BYVAL wFlags AS WORD, BYVAL pDispParams AS DISPPARAMS PTR, BYVAL pVarResult AS VARIANT PTR, BYVAL pExcepInfo AS EXCEPINFO PTR, BYVAL puArgErr AS UINT PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetDocumentation (BYVAL memid AS MEMBERID, BYVAL pBstrName AS AFX_BSTR PTR, BYVAL pBstrDocString AS AFX_BSTR PTR, BYVAL pdwHelpContext AS DWORD PTR, BYVAL pBstrHelpFile AS AFX_BSTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetDllEntry (BYVAL memid AS MEMBERID, BYVAL invKind AS INVOKEKIND, BYVAL pBstrDllName AS AFX_BSTR PTR, BYVAL pBstrName AS AFX_BSTR PTR, BYVAL pwOrdinal AS WORD PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetRefTypeInfo (BYVAL hRefType AS HREFTYPE, BYVAL ppTInfo AS Afx_ITypeInfo PTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION AddressOfMember (BYVAL memid AS MEMBERID, BYVAL invKind AS INVOKEKIND, BYVAL ppv AS PVOID PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION CreateInstance (BYVAL pUnkOuter AS IUnknown PTR, BYVAL riid AS CONST IID CONST PTR, BYVAL ppvObj AS PVOID PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetMops (BYVAL memid AS MEMBERID, BYVAL pBstrMops AS AFX_BSTR PTR) AS HRESULT
   DECLARE ABSTRACT FUNCTION GetContainingTypeLib (BYVAL ppTLib AS Afx_ITypeLib PTR PTR, BYVAL pIndex AS UINT PTR) AS HRESULT
   DECLARE ABSTRACT SUB      ReleaseTypeAttr (BYVAL pTypeAttr AS TYPEATTR PTR)
   DECLARE ABSTRACT SUB      ReleaseFuncDesc (BYVAL pFuncDesc AS FUNCDESC PTR)
   DECLARE ABSTRACT SUB      ReleaseVarDesc (BYVAL pVarDesc AS VARDESC PTR)
END TYPE

#endif


[José Roca]

To extract the type library information first wee need to rerieve how many TypeInfos it contains:

Code Select Expand


   ' // Retrieves the number of TypeInfos
   TypeInfoCount = m_pTypeLib->GetTypeInfoCount
   IF TypeInfoCount = 0 THEN
      TLB_MsgBox m_pWindow->hWindow, "This TypeLib doesn't have type infos", _
         MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.ParseTypeInfos"
      RETURN S_FALSE
   END IF


For each type info we will retrieve the type of a type description, a pointer to its ITypeInfo interface and a pointer to the TYPEATTR structure that contains the attributes of the type description.

Code Select Expand


   FOR i = 0 TO TypeInfoCount - 1

      ' // Retrieves the TypeKind
      hr = m_pTypeLib->GetTypeInfoType(i, @pTKind)
      IF hr <> S_OK THEN
         TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX$(hr, 8) & " retrieving the info type", _
            MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.ParseTypeInfos"
         EXIT FOR
      END IF

      ' // Retrieves the ITypeInfo interface
      hr = m_pTypeLib->GetTypeInfo(i, @pTypeInfo)
      IF hr <> S_OK OR pTypeInfo = NULL THEN
         TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX$(hr, 8) & " retrieving the ITypeInfo interface", _
            MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.ParseTypeInfos"
         EXIT FOR
      END IF

      ' // Gets the address of a pointer to the TYPEATTR structure
      hr = pTypeInfo->GetTypeAttr(@pTypeAttr)
      IF hr <> S_OK OR pTypeAttr = NULL THEN
         TLB_MsgBox m_pWindow->hWindow, "Error &H" & HEX$(hr, 8) & " retrieving the address of the TypeAttr structure", _
            MB_OK OR MB_ICONERROR OR MB_APPLMODAL, "CParseTypeLib.ParseTypeInfos"
         EXIT FOR
      END IF

      ...
      ...
      ...

NEXT


Inside the loop, we will process each block of information separately according its type:

Code Select Expand


      SELECT CASE pTKind
         CASE TKIND_COCLASS   ' // CoClasses
            ...
            ...
            ...
         CASE TKIND_RECORD, TKIND_UNION   ' // Structures and unions
            ...
            ...
            ...
         CASE TKIND_ALIAS   ' // Aliases and typedefs
            ...
            ...
            ...
         CASE TKIND_ENUM, TKIND_MODULE   ' // Enumerations and modules
            ...
            ...
            ...
         CASE TKIND_INTERFACE, TKIND_DISPATCH   ' // Interfaces
            ...
            ...
            ...
      END SELECT


[José Roca]

Enumerating the constants.

If the retrieved type info is of type TKIND_ENUM or TKIND_MODULE, the cvars member of the TYPEATTR structure ( https://msdn.microsoft.com/en-us/library/windows/desktop/ms221003(v=vs.85).aspx ) contains the number of variables and the GetVarDesc method of the ITypeInfo interface retrieves a VARDESC structure ( https://msdn.microsoft.com/en-us/library/windows/desktop/ms221391(v=vs.85).aspx ) that describes the specified variable.

Code Select Expand


' =====================================================================================
' Retrieves information about constants
' =====================================================================================
FUNCTION CParseTypeLib.GetConstants (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL pTypeAttr AS TYPEATTR PTR, BYVAL hTreeView AS HWND, BYVAL hSubNode AS HTREEITEM) AS HRESULT

   DIM hr AS HRESULT                      ' // HRESULT
   DIM x AS LONG                          ' // Loop counter
   DIM pVarDesc AS VARDESC PTR            ' // Pointer to a VARDESC structure
   DIM ptdesc AS TYPEDESC PTR             ' // Pointer to a TYPEDESC structure
   DIM cbstrName AS CBSTR                 ' // Name
   DIM vtPtr AS tagVARIANT PTR            ' // Pointer to a tagVARIANT structure
   DIM cbstrTypeKind AS CBSTR             ' // Type kind
   DIM cbstrValue AS CBSTR                ' // Value
   DIM bstrLen AS LONG                    ' // Length of the unicode string
   DIM wstrLen AS LONG                    ' // Length of the null-terminated unicode string
   DIM hSubNode2 AS HTREEITEM             ' // Sub node handle

   IF pTypeInfo = NULL OR pTypeAttr = NULL THEN RETURN E_INVALIDARG

   FOR x = 0 TO pTypeAttr->cVars - 1
      hr = pTypeInfo->GetVarDesc(x, @pVarDesc)
      IF hr <> S_OK OR pVarDesc = NULL THEN EXIT FOR
      cbstrName.Clear
      pTypeInfo->GetDocumentation(pVarDesc->memid, @cbstrName, NULL, NULL, NULL)
      ' // Some components use spaces in the names of enumeration members!
      IF INSTR(**cbstrName, " ") THEN
         cbstrName = AfxStrReplace(cbstrName, " ", "_")
      END IF
      ' // Pointer to the variant that stores the value of the constant
      vtPtr = pVarDesc->lpvarvalue
      ' // Gets the value of the constant
      cbstrValue.Clear : cbstrTypeKind.Clear
      cbstrValue = AfxVarToBstr(vtPtr)
      cbstrTypeKind = TLB_VarTypeToConstant(pVarDesc->elemdescVar.tdesc.vt)
      SELECT CASE pVarDesc->elemdescVar.tdesc.vt
         CASE VT_I1, VT_UI1, VT_I2, VT_UI2, VT_INT, VT_UINT
            cbstrValue = **cbstrValue & " (&h" & HEX(VAL(**cbstrValue), 8) & ")"
         CASE VT_BSTR, VT_LPSTR, VT_LPWSTR
            ' // cdosys.dll contains VT_BSTR constants
            cbstrValue = CHR(34) & **cbstrValue & CHR(34)
         CASE VT_PTR
            ptdesc = pVarDesc->elemdescVar.tdesc.lptdesc
            IF ptdesc THEN
               ' WORD PTR (null terminated unicode string)
               ' hxds.dll contains a module with these kind of constants.
               IF ptdesc->vt = VT_UI2 THEN cbstrValue = CHR(34) & **cbstrValue & CHR(34)
            END IF
         ' // Other types can be VT_CARRAY and VT_USERDEFINED, but don't have a typelib to test
      END SELECT
      hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, **cbstrName & " = " & **cbstrValue)
      TreeView_AddItem(hTreeView, hSubNode2, NULL, "TYPE = " & cbstrTypeKind)
      TreeView_AddItem(hTreeView, hSubNode2, NULL, "VALUE = " & cbstrValue)
      TreeView_AddItem(hTreeView, hSubNode2, NULL, "ID = " & WSTR(pVarDesc->memid))
      TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
      pTypeInfo->ReleaseVarDesc(pVarDesc)
      pVarDesc = NULL
   NEXT

   IF pVarDesc THEN pTypeInfo->ReleaseVarDesc(pVarDesc)

END FUNCTION
' =====================================================================================


Modules can also contain string constants and declarations of functions and procedures of external DLLs. This is covered by the following code in the GetFunctions method.

Code Select Expand


         IF pFuncDesc->elemdescFunc.tdesc.vt = VT_VOID THEN
            hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "SUB " & cbstrName)
         ELSE
            hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "FUNCTION " & cbstrName)
         END IF
         IF LEN(cbstrHelpString) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help string = " & cbstrHelpString)
         IF dwHelpContext THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help context = " & WSTR(dwHelpContext))
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "DispID = " & WSTR(pFuncDesc->memid) & " [&H" & HEX(pFuncDesc->memid, 8) & "]")
         cbstrDllName.Clear : cbstrEntryPoint.Clear
         hr = pTypeInfo->GetDllEntry(pFuncDesc->memid, pFuncDesc->invkind, @cbstrDllName, @cbstrEntryPoint, @wOrdinal)
         IF hr = S_OK THEN
            IF LEN(cbstrDllName) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "DLL name = " & cbstrDllName)
            IF LEN(cbstrEntryPoint) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Entry point = " & cbstrEntryPoint)
            IF wOrdinal THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Ordinal = " & WSTR(wOrdinal))
         END IF


[José Roca]

If the retrieved type info is of type TKIND_RECORD or TKIND_UNION, the cvars member of the TYPEATTR structure contains the number of members or data members and the GetVarDesc method of the ITypeInfo interface retrieves a VARDESC structure that describes the specified member or data member.

The parsing of this type info is more convoluted that in the case of the constants because they don't contain simple values, but the names and types of the members of an structure that can be simple data types, but also pointers, arrays or even other structures.

Code Select Expand


' =====================================================================================
' Retrieves information about the members of records and unions, and of datamembers.
' =====================================================================================
FUNCTION CParseTypeLib.GetMembers (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL pTypeAttr AS TYPEATTR PTR, BYVAL hTreeView AS HWND, BYVAL hSubNode AS HTREEITEM, BYVAL bIsRecord AS BOOLEAN = FALSE) AS HRESULT

   DIM x AS LONG                           ' // Loop counter
   DIM y AS LONG                           ' // Loop counter
   DIM hr AS HRESULT                       ' // HRESULT
   DIM pVarDesc AS VARDESC PTR             ' // Pointer to a VARDESC structure
   DIM cbstrVarName AS CBSTR               ' // Variable name
   DIM cbstrVarType AS CBSTR               ' // Variable type
   DIM cbstrTypeKind AS CBSTR              ' // Type kind
   DIM cbstrFBKeyword AS CBSTR             ' // FB keyword
   DIM cbstrFBSyntax AS CBSTR              ' // FB syntax
   DIM wIndirectionLevel AS WORD           ' // Indirection level
   DIM pRefTypeInfo AS Afx_ITypeInfo PTR   ' // Referenced TypeInfo interface
   DIM pVarTypeAttr AS TYPEATTR PTR        ' // Type attribute for the member
   DIM ptdesc AS TYPEDESC PTR              ' // Pointer to a TYPEDESC structure
   DIM padesc AS ARRAYDESC PTR             ' // Pointer to an ARRAYDESC structure
   DIM hSubNode2 AS HTREEITEM              ' // Sub node handle
   DIM hSubNode3 AS HTREEITEM              ' // Sub node handle

   IF pTypeInfo = NULL OR pTypeAttr = NULL THEN RETURN E_INVALIDARG

   FOR x = 0 TO pTypeAttr->cVars - 1

      cbstrVarType.Clear : cbstrTypeKind.Clear : cbstrFBKeyword.Clear

      ' // Gets a reference to the VarDesc structure
      hr = pTypeInfo->GetVarDesc(x, @pVarDesc)
      IF hr <> S_OK OR pVarDesc = NULL THEN EXIT FOR

      ' // Retrieve information
      pTypeInfo->GetDocumentation(pVarDesc->memid, @cbstrVarName, NULL, NULL, NULL)
      hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, cbstrVarName)
      TreeView_AddItem(hTreeView, hSubNode2, NULL, "DispID = " & WSTR(pVarDesc->memid) & " [&H" & HEX(pVarDesc->memid, 8) & "]")
      IF pVarDesc->wVarFlags THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Attributes = " & WSTR(pVarDesc->wVarFlags) & " [&H" & HEX(pVarDesc->wVarFlags, 8) & "]" & TLB_VarFlagsToStr(pVarDesc->wVarFlags))
      wIndirectionLevel = 0
      IF pVarDesc->elemdescVar.tdesc.vt = VT_USERDEFINED THEN
         ' // If it is a user defined type, retrieve its name
         hr = pTypeInfo->GetRefTypeInfo(pVarDesc->elemdescVar.tdesc.hreftype, @pRefTypeInfo)
         IF hr = S_OK AND pRefTypeInfo <> NULL THEN
            cbstrVarType.Clear
            hr = pRefTypeInfo->GetDocumentation(-1, @cbstrVarType, NULL, NULL, NULL)
            hr = pRefTypeInfo->GetTypeAttr(@pVarTypeAttr)
            IF hr = S_OK AND pVarTypeAttr <> NULL THEN
               IF pVarTypeAttr->typekind = TKIND_ALIAS THEN
                  cbstrTypeKind = TLB_TypeKindToStr(pVarTypeAttr->typekind) & " | " & TLB_VarTypeToConstant(pVarTypeAttr->tdescalias.vt)
               ELSE
                  cbstrTypeKind = TLB_TypeKindToStr(pVarTypeAttr->typekind)
               END IF
               TreeView_AddItem(hTreeView, hSubNode2, NULL, "TypeKind = " & cbstrTypeKind)
               pRefTypeInfo->ReleaseTypeAttr(pVarTypeAttr)
               pVarTypeAttr = NULL
            END IF
            IF pRefTypeInfo THEN pRefTypeInfo->Release
         END IF
      ELSEIF pVarDesc->elemdescVar.tdesc.vt = VT_PTR THEN
         wIndirectionLevel = 1
         ptdesc = pVarDesc->elemdescVar.tdesc.lptdesc
         DO
            SELECT CASE ptdesc->vt
               ' // If it is another pointer, loop again
               CASE VT_PTR
                  wIndirectionLevel += 1
                  ptdesc = ptdesc->lptdesc
               CASE VT_USERDEFINED
                  hr = pTypeInfo->GetRefTypeInfo(ptdesc->hreftype, @pRefTypeInfo)
                  IF hr = S_OK AND pRefTypeInfo <> NULL THEN
                     cbstrVarType.Clear
                     hr = pRefTypeInfo->GetDocumentation(-1, @cbstrVarType, NULL, NULL, NULL)
                     IF hr = S_OK THEN
                        pRefTypeInfo->GetTypeAttr(@pVarTypeAttr)
                        IF hr = S_OK AND pVarTypeAttr <> NULL THEN
                           IF pVarTypeAttr->typekind = TKIND_ALIAS THEN
                              cbstrTypeKind = TLB_TypeKindToStr(pVarTypeAttr->typekind) & " | " & TLB_VarTypeToConstant(pVarTypeAttr->tdescalias.vt)
                           ELSE
                              cbstrTypeKind = TLB_TypeKindToStr(pVarTypeAttr->typekind)
                           END IF
                           TreeView_AddItem(hTreeView, hSubNode2, NULL, "TypeKind = " & cbstrTypeKind)
                           pRefTypeInfo->ReleaseTypeAttr(pVarTypeAttr)
                           pVarTypeAttr = NULL
                        END IF
                     END IF
                     IF pRefTypeInfo THEN pRefTypeInfo->Release
                     EXIT DO
                  END IF
               CASE ELSE
                  ' // Get the equivalent type
                  cbstrVarType = TLB_VarTypeToConstant(ptdesc->vt)
                  cbstrFBKeyword = TLB_VarTypeToKeyword(ptdesc->vt)
                  EXIT DO
            END SELECT
         LOOP
      ELSE
         ' // Get the equivalent type
         cbstrVarType = TLB_VarTypeToConstant(pVarDesc->elemdescVar.tdesc.vt)
         cbstrFBKeyword = TLB_VarTypeToKeyword(pVarDesc->elemdescVar.tdesc.vt)
      END IF

      IF bIsRecord = FALSE THEN
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "VarType = " & cbstrVarType)
      ELSE   ' // Records and unions only
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "Indirection level = " & WSTR(wIndirectionLevel))
'           ' // Add a prefix to structures that begin with an underscore
'            IF LEFT(**cbstrVarType, 1) = "_" THEN
'               IF cbstrTypeKind = "TKIND_RECORD" OR cbstrTypeKind = "TKIND_UNION" THEN cbstrVarType = "tag" & cbstrVarType
'            END IF
         ' // END isn't allowed as a member name
         IF UCASE(cbstrVarName) = "END" THEN cbstrVarName += "_"
         ' // Use generic data types for enums and interfaces
         IF cbstrFBKeyword = "" THEN cbstrFBKeyword = cbstrVarType
'         ' // Add a prefix to structures that begin with an underscore
'         IF LEFT(**cbstrFBKeyword, 1) = "_" THEN
'            IF cbstrTypeKind = "TKIND_RECORD" OR cbstrTypeKind = "TKIND_UNION" THEN cbstrFBKeyword = "tag" & cbstrFBKeyword
'         END IF
         IF wIndirectionLevel > 0 THEN cbstrFBKeyword += " PTR"
         IF cbstrTypeKind = "TKIND_ALIAS | VT_PTR" THEN cbstrFBKeyword = "VOID"
         IF cbstrTypeKind = "TKIND_ENUM" THEN cbstrFBKeyword = cbstrVarType
         IF cbstrTypeKind = "TKIND_UNKNOWN" THEN cbstrFBKeyword = "IUnknown PTR"
         IF cbstrTypeKind = "TKIND_DISPATCH" THEN cbstrFBKeyword = "IDispatch PTR"
         IF pVarDesc->elemdescVar.tdesc.vt = VT_CARRAY THEN
            padesc = pVarDesc->elemdescVar.tdesc.lpadesc
            cbstrVarType += " | " & TLB_VarTypeToConstant(padesc->tdescElem.vt)
            cbstrVarName += " ("
            FOR y = 0 TO padesc->cDims - 1
               cbstrVarName += WSTR(padesc->rgbounds(y).lLBound) & " TO "
               cbstrVarName += WSTR(padesc->rgbounds(y).lLBound + padesc->rgbounds(y).cElements - 1)
               IF padesc->cDims > 1 THEN cbstrVarName += ", "
            NEXT
            cbstrVarName += ")"
            cbstrFBKeyword = TLB_VarTypeToKeyword(padesc->tdescElem.vt)
         END IF
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "VarType = " & cbstrVarType)
         IF pVarDesc->elemdescVar.tdesc.vt = VT_CARRAY THEN
            padesc = pVarDesc->elemdescVar.tdesc.lpadesc
            hSubNode3 = TreeView_AddItem(hTreeView, hSubNode2, NULL, "Dimensions = " & WSTR(padesc->cDims))
            FOR y = 0 TO padesc->cDims - 1
               TreeView_AddItem(hTreeView, hSubNode3, NULL, "Dimension " & WSTR(y + 1) & " lower bound = " & WSTR(padesc->rgbounds(y).lLBound))
               TreeView_AddItem(hTreeView, hSubNode3, NULL, "Dimension " & WSTR(y + 1) & " elements = " & WSTR(padesc->rgbounds(y).cElements))
            NEXT
            TreeView_Expand(hTreeView, hSubNode3, TVE_EXPAND)
         END IF
'         ' // FB syntax
         SELECT CASE **cbstrVarType
            CASE "VT_LPSTR"
               cbstrFBSyntax = cbstrVarName & " AS ZSTRING PTR"
            CASE "VT_LPWSTR"
               cbstrFBSyntax = cbstrVarName & " AS WSTRING PTR"
            CASE ELSE
               cbstrFBSyntax = **cbstrVarName & " AS " & **cbstrFBKeyword
         END SELECT
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "FB syntax = " & cbstrFBSyntax)
      END IF

      ' // Expand the nodes
'         TreeView_Expand(hTreeView, hSubNode2, TVE_EXPAND)
      TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
      ' // Release the VARDESC structure
      pTypeInfo->ReleaseVarDesc(pVarDesc)
      pVarDesc = NULL

   NEXT

   IF pVarDesc THEN pTypeInfo->ReleaseVarDesc(pVarDesc)

   ' // Just to satisfy the compiler rules; it has no useful meaning
   FUNCTION = hr

END FUNCTION
' =====================================================================================


[José Roca]

Aliases and typedefs

Some type libraries use aliases and typedefs to give alternate names to data types, enumerations or structures. For example, ADO uses ADO_LONGPTR as a typedef of a LongInteger and SearchDirection as an alias of SearchDirectionEnum.

Code Select Expand


         ' ----------------------------------------------------------------------------
         ' Aliases and typedefs
         ' ----------------------------------------------------------------------------
         CASE TKIND_ALIAS
            cbstrName.Clear : cbstrOrigName.Clear : cbstrAliasName.Clear : cbstrAliasName2.Clear : cbstrTypedefName.Clear
            hr = m_pTypeLib->GetDocumentation(i, @cbstrName, NULL, NULL, NULL)
            IF hr = S_OK THEN
               cbstrOrigName = cbstrName
               IF pTypeAttr->tdescAlias.vt = VT_USERDEFINED THEN
                  ' // If it is a user defined type, retrieve its name
                  hr = pTypeInfo->GetRefTypeInfo(pTypeAttr->tdescAlias.hreftype, @pRefTypeInfo)
                  IF hr = S_OK AND pRefTypeInfo <> NULL THEN
                     cbstrName.Clear
                     hr = pRefTypeInfo->GetDocumentation(-1, @cbstrName, NULL, NULL, NULL)
                     IF hr = S_OK THEN
                        cbstrAliasName = **cbstrOrigName & " = " & **cbstrName
                        cbstrAliasName2 = **cbstrName & " = " & **cbstrOrigName
                     END IF
                     pRefTypeInfo->Release
                     pRefTypeInfo = NULL
                  END IF
               ELSEIF pTypeAttr->tdescAlias.vt = VT_PTR THEN
                  ' // Pointer to a TYPEDESC structure
                  ptdesc = pTypeAttr->tdescAlias.lptdesc
                  DO
                     SELECT CASE ptdesc->vt
                        ' // If it is a pointer, do it again
                        CASE VT_PTR
                           ptdesc = ptdesc->lptdesc
                        CASE VT_USERDEFINED
                           ' // Retrieve the name of the user defined type
                           hr = pTypeInfo->GetRefTypeInfo(ptdesc->hreftype, @pRefTypeInfo)
                           IF hr = S_OK AND pRefTypeInfo <> NULL THEN
                              cbstrName.Clear
                              hr = pRefTypeInfo->GetDocumentation(-1, @cbstrName, NULL, NULL, NULL)
                              IF hr = S_OK THEN
                                 cbstrAliasName = **cbstrOrigName & " = " & **cbstrName
                                 cbstrAliasName2 = **cbstrName & " = " & **cbstrOrigName
                              END IF
                              pRefTypeInfo->Release
                              pRefTypeInfo = NULL
                           END IF
                           EXIT DO
                        CASE ELSE
                           ' // Get the equivalent type
                           cbstrTypedefName = cbstrName & " = " & TLB_VarTypeToConstant(ptdesc->vt) & " <" & TLB_VarTypeToKeyword(pTypeAttr->tdescAlias.vt) & ">"
                           EXIT DO
                     END SELECT
                  LOOP
               ELSE
                  ' // Get the equivalent type
                  cbstrTypedefName = cbstrName & " = " & TLB_VarTypeToConstant(pTypeAttr->tdescAlias.vt) & " <" & TLB_VarTypeToKeyword(pTypeAttr->tdescAlias.vt) & ">"
               END IF
               IF LEN(cbstrTypedefName) THEN
                  TreeView_AddItem hTreeView, m_hTypedefsNode, NULL, cbstrTypedefName
               ELSE
                  TreeView_AddItem hTreeView, m_hAliasesNode, NULL, cbstrAliasName
                  TreeView_AddItem hTreeView, m_hAliasesNode, NULL, cbstrAliasName2
               END IF
            END IF
         ' ----------------------------------------------------------------------------


[José Roca]

CoClases

The CoClasses provide information about each COM class, such the ProgID (Program Identifier), CLSID (Class Identifier), attributes, the in-process server and the implemented interfaces.

Code Select Expand


         CASE TKIND_COCLASS
            ' // Get the name of the CoClass
            cbstrName.Clear : cbstrHelpString.Clear : cbstrHelpFile.Clear
            hr = m_pTypeLib->GetDocumentation(i, @cbstrName, @cbstrHelpString, @dwHelpContext, @cbstrHelpFile)
            hNode = TreeView_AddItem(hTreeView, m_hCoClassesNode, NULL, cbstrName)
            ' // ProgIDs node
            ' Some external programs, such McAffee Antivirus, modify the typelibs of
            ' components such Windows Script Host to redirect it to its own server.
            ' This originates duplicate ProgIDs, so we need to search if the ProgID
            ' is already listed to avoid duplicates.
            cbstrProgID.Clear
            cbstrProgID = TLB_GetProgID(AfxGuidText(pTypeAttr->guid))
            IF LEN(cbstrProgID) THEN
               IF _TreeView_ItemExists(hTreeView, m_hProgIDsNode, cbstrProgID) = FALSE THEN
                  TreeView_AddItem hTreeView, m_hProgIDsNode, NULL, cbstrProgID
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "ProgID")
                  TreeView_AddItem hTreeView, hSubNode, NULL, cbstrProgID
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
               END IF
            END IF
            ' // Version independent ProgIDs node
            ' Note: Search if it already exists because there are components like
            ' MSXML that allow side-by-side installation of several versions that have
            ' different ProgIDs but, of course, the same independent version ProgID.
            cbstrProgID = TLB_GetVersionIndependentProgID(AfxGuidText(pTypeAttr->guid))
            IF LEN(cbstrProgID) THEN
               IF _TreeView_ItemExists(hTreeView, m_hVerIndProgIDsNode, cbstrProgID) = FALSE THEN
                  TreeView_AddItem hTreeView, m_hVerIndProgIDsNode, NULL, cbstrProgID
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Version independent ProgID")
                  TreeView_AddItem hTreeView, hSubNode, NULL, cbstrProgID
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
               END IF
            END IF
            ' // ClsIDs nodes
            TreeView_AddItem hTreeView, m_hClsIDsNode, NULL, "CLSID_" & cbstrName & " = " & CHR(34) & AfxGuidText(pTypeAttr->guid) & CHR(34)
            hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "CLSID")
            TreeView_AddItem hTreeView, hSubNode, NULL, AfxGuidText(pTypeAttr->guid)
            TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            ' // Attributes
            hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Attributes")
            TreeView_AddItem hTreeView, hSubNode, NULL, WSTR(pTypeAttr->wTypeFlags) & " [&H" & HEX(pTypeAttr->wTypeFlags, 8) & "]" & TLB_InterfaceFlagsToStr(pTypeAttr->wTypeFlags)
            TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            ' // Help info
            IF LEN(cbstrHelpString) THEN
               hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Help string")
               TreeView_AddItem hTreeView, hSubNode, NULL, cbstrHelpString
               TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            END IF
            IF dwHelpContext THEN
               hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Help context")
               TreeView_AddItem hTreeView, hSubNode, NULL, WSTR(dwHelpContext) & " [&H" & HEX(dwHelpContext, 8) & "]"
               TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            END IF
            IF LEN(cbstrHelpFile) THEN
               hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Help file")
               TreeView_AddItem hTreeView, hSubNode, NULL, cbstrHelpFile
               TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            END IF
            ' // InProcServer32
            cbstrInProcServer = TLB_GetInprocServer32(AfxGuidText(pTypeAttr->guid))
            IF LEN(cbstrInProcServer) THEN
               hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "InProcServer32")
               TreeView_AddItem hTreeView, hSubNode, NULL, cbstrInProcServer
               TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
            END IF
            ' // Retrieve the implemented interfaces
            ' Note: Don't release pRefType or it will explode
            cImplTypes = pTypeAttr->cImplTypes
            IF cImplTypes THEN hImplIntSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Implemented interfaces")
            FOR x = 0 TO cImplTypes - 1
               lImplTypeFlags = 0
               hr = pTypeInfo->GetImplTypeFlags(x, @lImplTypeFlags)
               IF hr <> S_OK THEN EXIT FOR
               pRefType = 0
               hr = pTypeInfo->GetRefTypeOfImplType(x, @pRefType)
               IF hr <> S_OK THEN EXIT FOR
               hr = pTypeInfo->GetRefTypeInfo(pRefType, @pImplTypeInfo)
               IF hr <> S_OK OR pImplTypeInfo = NULL THEN EXIT FOR
               cbstrName.Clear
               hr = pImplTypeInfo->GetDocumentation(-1, @cbstrName, NULL, NULL, NULL)
               IF hr <> S_OK THEN EXIT FOR
               TreeView_AddItem hTreeView, hImplIntSubNode, NULL, cbstrName
               TreeView_Expand(hTreeView, hImplIntSubNode, TVE_EXPAND)
               pImplTypeAttr = 0
               pImplTypeInfo->GetTypeAttr(@pImplTypeAttr)
               IF lImplTypeFlags = IMPLTYPEFLAG_FDEFAULT THEN   ' // Default interface
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Default interface")
                  TreeView_AddItem hTreeView, hSubNode, NULL, cbstrName
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Default interface IID")
                  IF pImplTypeAttr THEN TreeView_AddItem hTreeView, hSubNode, NULL, AfxGuidText(pImplTypeAttr->guid)
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
               ELSEIF lImplTypeFlags = IMPLTYPEFLAG_FSOURCE THEN   ' // Events interface
                  ' // Some components, such Office 12's AccWiz.dll, have deprecated CoClasses that
                  ' // implement the same events interfaces that the new one. We need to check if the
                  ' // interface is hidden to avoid listing them twice.
                  IF (pTypeAttr->wTypeFlags AND TYPEFLAG_FHIDDEN) <> TYPEFLAG_FHIDDEN THEN
                     IF _TreeView_ItemExists(hTreeView, m_hEventsNode, cbstrName) = FALSE THEN
                        TreeView_AddItem hTreeView, m_hEventsNode, NULL, cbstrName
                     END IF
                  END IF
               ELSEIF lImplTypeFlags = (IMPLTYPEFLAG_FDEFAULT OR IMPLTYPEFLAG_FSOURCE) THEN   ' // Default events interface
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Default events interface")
                  TreeView_AddItem hTreeView, hSubNode, NULL, cbstrName
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
                  hSubNode = TreeView_AddItem(hTreeView, hNode, NULL, "Default events interface IID")
                  IF pImplTypeAttr THEN TreeView_AddItem hTreeView, hSubNode, NULL, AfxGuidText(pImplTypeAttr->guid)
                  TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
                  ' // Some components, such Office 12's AccWiz.dll, have deprecated CoClasses that
                  ' // implement the same events interfaces that the new one. We need to check if the
                  ' // interface is hidden to avoid listing them twice.
                  IF (pTypeAttr->wTypeFlags AND TYPEFLAG_FHIDDEN) <> TYPEFLAG_FHIDDEN THEN
                     IF _TreeView_ItemExists(hTreeView, m_hEventsNode, cbstrName) = FALSE THEN
                        TreeView_AddItem hTreeView, m_hEventsNode, NULL, cbstrName
                     END IF
                  END IF
               END IF
               IF pImplTypeAttr THEN
                  IF pImplTypeInfo THEN pImplTypeInfo->ReleaseTypeAttr(pImplTypeAttr)
                  pImplTypeAttr = NULL
               END IF
            NEXT
            IF pImplTypeAttr THEN
               IF pImplTypeInfo THEN pImplTypeInfo->ReleaseTypeAttr(pImplTypeAttr)
               pImplTypeAttr = NULL
            END IF
            IF pImplTypeInfo THEN
               pImplTypeInfo->Release
               pImplTypeInfo = NULL
            END IF


[José Roca]

Interfaces

The type infos TKIND_INTERFACE and TKIND_DISPATCH provide information about the implemented interfaces and its methods and properties.

Code Select Expand


         CASE TKIND_INTERFACE, TKIND_DISPATCH
            cbstrName.Clear : cbstrHelpString.Clear
            hr = m_pTypeLib->GetDocumentation(i, @cbstrName, @cbstrHelpString, NULL, NULL)
            IF hr = S_OK THEN
               TreeView_AddItem hTreeView, m_hIIDsNode, NULL, "IID_" & cbstrName & " = " & CHR(34) & AfxGuidText(pTypeAttr->guid) & CHR(34)
               DIM vTableView AS BOOLEAN = TRUE
               ' // Get the use automation view option
               DIM wszBuffer AS WsTRING * MAX_PATH
               DIM wszIniFileName AS WSTRING * MAX_PATH = ExePath & "\" & INIFILENAME
               GetPrivateProfileStringW("Browser options", "UseAutomationView", NULL, @wszBuffer, MAX_PATH, @wszIniFileName)
               IF VAL(wszBuffer) = 1 THEN vTableView = FALSE   ' // Use Automation view
               ' ------------------------------------------------------------------------------------------
               ' Use VTable view
               ' ------------------------------------------------------------------------------------------
               IF vTableView = TRUE THEN
                  DO   ' // Fake DO LOOP to allow exit without GOTO
                     ' // Attempt to change the view to VTable
                     pRefType = NULL
                     hr = pTypeInfo->GetRefTypeOfImplType(-1, @pRefType)
                     IF hr <> S_OK OR pRefType = NULL THEN
                        vTableView = FALSE
                        EXIT DO
                     END IF
                     hr = pTypeInfo->GetRefTypeInfo(pRefType, @pRefTypeInfo)
                     IF hr <> S_OK OR pRefTypeInfo = NULL THEN
                        vTableView = FALSE
                        EXIT DO
                     END IF
                     pRefTypeAttr = NULL
                     hr = pRefTypeInfo->GetTypeAttr(@pRefTypeAttr)
                     hSubNode = TreeView_AddItem(hTreeView, m_hDualIntNode, NULL, cbstrName)
                     IF AfxGuidText(pRefTypeAttr->guid) <> "{00000000-0000-0000-0000-000000000000}" THEN
                        TreeView_AddItem(hTreeView, hSubNode, NULL, "IID: " & AfxGuidText(pRefTypeAttr->guid))
                     END IF
                     IF LEN(cbstrHelpString) THEN TreeView_AddItem(hTreeView, hSubNode, NULL, "Documentation string: " & cbstrHelpString)
                     IF pRefTypeAttr->wTypeFlags THEN TreeView_AddItem(hTreeView, hSubNode, NULL, "Attributes =  " & WSTR(pRefTypeAttr->wTypeFlags) & " [&H" & HEX(pRefTypeAttr->wTypeFlags, 8) & "]" & TLB_InterfaceFlagsToStr(pRefTypeAttr->wTypeFlags))
                     cbstrInheritedInterface = TLB_GetImplementedInterface(pRefTypeInfo)
                     TreeView_AddItem(hTreeView, hSubNode, NULL, "Inherited interface = " & cbstrInheritedInterface)
                     ' /*** Datamembers ***/
                     IF pRefTypeAttr->cVars THEN
                        hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "Number of datamembers " & WSTR(pRefTypeAttr->cVars))
                        this.GetMembers (pRefTypeInfo, pRefTypeAttr, hTreeView, hSubNode2)
                     END IF
                     ' /*** Retrieves the methods and properties ***/
                     IF @pRefTypeAttr->cFuncs THEN
                        hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "Number of methods = " & WSTR(pRefTypeAttr->cFuncs))
                        this.GetFunctions(pRefTypeInfo, pREfTypeAttr, hTreeView, hSubNode2, TRUE, pTKind, cbstrImplInterface)
                     END IF
                     IF pRefTypeInfo THEN
                        IF pTypeAttr THEN pRefTypeInfo->ReleaseTypeAttr(pRefTypeAttr)
                        pRefTypeInfo->Release
                     END IF
                     ' // exit the fake loop
                     EXIT DO
                  LOOP
               END IF
               ' ------------------------------------------------------------------------------------------
               ' Use Automation view, aka Visual Basic view
               ' ------------------------------------------------------------------------------------------
               IF vTableView = FALSE THEN
                  cbstrImplInterface = TLB_GetImplementedInterface(pTypeInfo)
                  IF cbstrImplInterface <> "" THEN
                     IF UCASE(cbstrImplInterface) <> "IUNKNOWN" AND UCASE(cbstrImplInterface) <> "IDISPATCH" THEN
                        cbstrImplInterface = TLB_GetBaseClass(m_pTypeLib, cbstrName)
                     END IF
                  END IF
                  IF pTKind = TKIND_INTERFACE THEN
                     IF UCASE$(cbstrImplInterface) = "IUNKNOWN" AND (pTypeAttr->wTypeFlags AND TYPEFLAG_FOLEAUTOMATION) = TYPEFLAG_FOLEAUTOMATION THEN
                        hSubNode = TreeView_AddItem(hTreeView, m_hOleAutIntNode, NULL, cbstrName)
                     ELSEIF UCASE(cbstrImplInterface) = "IDISPATCH" AND (pTypeAttr->wTypeFlags AND TYPEFLAG_FDUAL) <> TYPEFLAG_FDUAL THEN
                        hSubNode = TreeView_AddItem(hTreeView, m_hDispblIntNode, NULL, cbstrName)
                     ELSE
                        hSubNode = TreeView_AddItem(hTreeView, m_hIntNode, NULL, cbstrName)
                     END IF
                  ELSEIF pTKind = TKIND_DISPATCH THEN
                     IF (pTypeAttr->wTypeFlags AND TYPEFLAG_FDUAL) = TYPEFLAG_FDUAL THEN
                        hSubNode = TreeView_AddItem(hTreeView, m_hDualIntNode, NULL, cbstrName)
                     ELSE
                        hSubNode = TreeView_AddItem(hTreeView, m_hDispIntNode, NULL, cbstrName)
                     END IF
                  END IF
                  IF AfxGuidText(pTypeAttr->guid) <> "{00000000-0000-0000-0000-000000000000}" THEN
                     TreeView_AddItem(hTreeView, hSubNode, NULL, "IID: " & AfxGuidText(pTypeAttr->guid))
                  END IF
                  IF LEN(cbstrHelpString) THEN TreeView_AddItem(hTreeView, hSubNode, NULL, "Documentation string: " & cbstrHelpString)
                  IF pTypeAttr->wTypeFlags THEN TreeView_AddItem(hTreeView, hSubNode, NULL, "Attributes =  " & WSTR(pTypeAttr->wTypeFlags) & " [&H" & HEX(pTypeAttr->wTypeFlags, 8) & "]" & TLB_InterfaceFlagsToStr(pTypeAttr->wTypeFlags))
                  IF LEN(cbstrImplInterface) THEN TreeView_AddItem(hTreeView, hSubNode, NULL, "Inherited interface = " & cbstrImplInterface)
                  ' /*** Datamembers ***/
                  IF pTypeAttr->cVars THEN
                     hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "Number of datamembers " & WSTR(pTypeAttr->cVars))
                     this.GetMembers (pTypeInfo, pTypeAttr, hTreeView, hSubNode2)
                  END IF
                  ' /*** Retrieves the methods and properties ***/
                  IF pTypeAttr->cFuncs THEN
                     hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "Number of methods = " & WSTR(pTypeAttr->cFuncs))
                     this.GetFunctions(pTypeInfo, pTypeAttr, hTreeView, hSubNode2, TRUE, pTKind, cbstrImplInterface)
                  END IF
               END IF
            END IF


A very important particularity is that the information can be returned in two different kind of views, the VTable view and the Automation view, aka Visual Basic view, that it is the default (after all, Automation was designed by te VB team).

To change the type of views from the default Automation one to the VTable one, we have to call the GetRefTypeOfImplType of the ITypeInfo interface. The meager documentation provided by Microsoft states that "If a type description describes a COM class, it retrieves the type description of the implemented interface types. For an interface, GetRefTypeOfImplType returns the type information for inherited interfaces, if any exist." See: https://msdn.microsoft.com/en-us/library/windows/desktop/ms221569(v=vs.85).aspx

This doesn't help much, does it? Fortunately, there is a remark at the bottom: "If the TKIND_DISPATCH type description is for a dual interface, the TKIND_INTERFACE type description can be obtained by calling GetRefTypeOfImplType with an indexof â€"1, and by passing the returned pRefTypehandle to GetRefTypeInfo to retrieve the type information."

So, if we have a TKIND_DISPATCH description and be want a TKIND_INTERFACE description (assuming that the Dispatch interface is dual and not a dispatch only interface), we can get it passing -1 to GetRefTypeOfImplType.

Code Select Expand


                     ' // Attempt to change the view to VTable
                     pRefType = NULL
                     hr = pTypeInfo->GetRefTypeOfImplType(-1, @pRefType)
                     IF hr <> S_OK OR pRefType = NULL THEN
                        vTableView = FALSE
                        EXIT DO
                     END IF
                     hr = pTypeInfo->GetRefTypeInfo(pRefType, @pRefTypeInfo)
                     IF hr <> S_OK OR pRefTypeInfo = NULL THEN
                        vTableView = FALSE
                        EXIT DO
                     END IF
                     pRefTypeAttr = NULL
                     hr = pRefTypeInfo->GetTypeAttr(@pRefTypeAttr)


[José Roca]

The cFuncs member of the TYPEATTR structure contains the number of methods and properties implemented in an interface and the GetFuncDesc method of the ITypeInfo interface retrieves the FUNCDESC structure that contains information about a specified function ( https://msdn.microsoft.com/en-us/library/windows/desktop/ms221425(v=vs.85).aspx ), as well as the return type.

Code Select Expand


' =====================================================================================
' Retrieve information about the methods, properties and functions.
' =====================================================================================
FUNCTION CParseTypeLib.GetFunctions (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL pTypeAttr AS TYPEATTR PTR, BYVAL hTreeView AS HWND, BYVAL hSubNode AS HTREEITEM, BYVAL bIsMethod AS BOOLEAN = FALSE, BYVAL pTKind AS TYPEKIND = 0, BYVAL pwszImplInterface AS WSTRING PTR = NULL) AS HRESULT

   DIM hr AS HRESULT                       ' // HRESULT
   DIM x AS LONG                           ' // Loop counter
   DIM hSubNode2 AS HTREEITEM              ' // Sub node handle
   DIM pFuncDesc AS FUNCDESC PTR           ' // Pointer to a FUNCDESC structure
   DIM cbstrName AS CBSTR                  ' // Name
   DIM cbstrHelpString AS CBSTR            ' // Help string
   DIM dwHelpContext AS DWORD              ' // Help context number
   DIM cbstrDllName AS CBSTR               ' // DLL name
   DIM cbstrEntryPoint AS CBSTR            ' // Entry point
   DIM wOrdinal AS WORD                    ' // Ordinal
   DIM pRefTypeInfo AS Afx_ITypeInfo PTR   ' // Referenced TypeInfo interface
   DIM pReturnTypeAttr AS TYPEATTR PTR     ' // Referenced TYPEATTR structure
   DIM ptdesc AS TYPEDESC PTR              ' // Pointer to a TYPEDESC structure

   IF pTypeInfo = NULL OR pTypeAttr = NULL THEN RETURN E_INVALIDARG

   FOR x = 0 TO pTypeAttr->cFuncs - 1
      ' // Gets a reference to the FuncDesc structure
      hr = pTypeInfo->GetFuncDesc(x, @pFuncDesc)
      IF hr <> S_OK OR pFuncDesc = NULL THEN EXIT FOR
      ' // Retrieve the name
      cbstrName.Clear : cbstrHelpString.Clear
      pTypeInfo->GetDocumentation(pFuncDesc->memid, @cbstrName, @cbstrHelpString, @dwHelpContext, NULL)
      IF bIsMethod THEN
         ' ------------------------------------------------------------------
         ' Workaround for libraries that can have illegal method names.
         ' For example, TLBINF32.DLL has a property called GetTypeInfo.
         ' ------------------------------------------------------------------
         DIM vtOffset AS LONG
#ifdef __FB_64BIT__
         vtOffset = 48
#else
         vtOffset = 24
#endif
         IF UCASE$(cbstrName) = "QUERYINTERFACE" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "ADDREF" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "RELEASE" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "GETTYPEINFOCOUNT" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "GETTYPEINFO" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "GETIDSOFNAMES" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         IF UCASE$(cbstrName) = "INVOKE" AND pFuncdesc->oVft > vtOffset THEN cbstrName += "_"
         ' ------------------------------------------------------------------
'            IF pTKind = TKIND_DISPATCH THEN
'               IF cbstrName = "QueryInterface" OR cbstrName = "AddRef" OR cbstrName = "Release" OR _
'                  cbstrName = "GetTypeInfoCount" OR cbstrName = "GetTypeInfo" OR _
'                  cbstrName = "GetIDsOfNames" OR cbstrName = "Invoke" THEN
'                  ' // Release the FUNCDESC structure
'                  pTypeInfo->ReleaseFuncDesc(pFuncDesc)
'                  pFuncDesc = NULL
'                  ' // Iterate the loop
'                  CONTINUE FOR
'               END IF
'            END IF
         IF pTKind = TKIND_INTERFACE OR pTKind = TKIND_DISPATCH THEN
            IF pFuncDesc->invkind = INVOKE_FUNC THEN cbstrName = "METHOD " & cbstrName
            IF pFuncDesc->invkind = INVOKE_PROPERTYGET THEN cbstrName = "PROPERTY GET " & cbstrName
            IF pFuncDesc->invkind = INVOKE_PROPERTYPUT THEN cbstrName = "PROPERTY PUT " & cbstrName
            IF pFuncDesc->invkind = INVOKE_PROPERTYPUTREF THEN cbstrName = "PROPERTY PUTREF " & cbstrName
         END IF
         hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, cbstrName)
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "VTable offset = " &  WSTR(pFuncdesc->oVft) & " [&H" & HEX(pFuncdesc->oVft, 8) & "]")
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "DispID = " & WSTR(pFuncDesc->memid) & " [&H" & HEX(@pFuncDesc->memid, 8) & "]")
         IF LEN(cbstrHelpString) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help string = " & cbstrHelpString)
         IF dwHelpContext THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help context = " & WSTR(dwHelpContext))
      ELSE
         IF pFuncDesc->elemdescFunc.tdesc.vt = VT_VOID THEN
            hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "SUB " & cbstrName)
         ELSE
            hSubNode2 = TreeView_AddItem(hTreeView, hSubNode, NULL, "FUNCTION " & cbstrName)
         END IF
         IF LEN(cbstrHelpString) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help string = " & cbstrHelpString)
         IF dwHelpContext THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Help context = " & WSTR(dwHelpContext))
         TreeView_AddItem(hTreeView, hSubNode2, NULL, "DispID = " & WSTR(pFuncDesc->memid) & " [&H" & HEX(pFuncDesc->memid, 8) & "]")
         cbstrDllName.Clear : cbstrEntryPoint.Clear
         hr = pTypeInfo->GetDllEntry(pFuncDesc->memid, pFuncDesc->invkind, @cbstrDllName, @cbstrEntryPoint, @wOrdinal)
         IF hr = S_OK THEN
            IF LEN(cbstrDllName) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "DLL name = " & cbstrDllName)
            IF LEN(cbstrEntryPoint) THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Entry point = " & cbstrEntryPoint)
            IF wOrdinal THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Ordinal = " & WSTR(wOrdinal))
         END IF
      END IF

      ' // Kind of function
      SELECT CASE pFuncDesc->funckind
         CASE FUNC_VIRTUAL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "FuncKind = Virtual")
         CASE FUNC_PUREVIRTUAL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "FuncKind = Pure virtual")
         CASE FUNC_NONVIRTUAL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "FuncKind = Non virtual")
         CASE FUNC_STATIC
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "FuncKind = Static")
         CASE FUNC_DISPATCH
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "FuncKind = Dispatch")
      END SELECT
      ' // Invoke kind
      SELECT CASE pFuncDesc->invkind
         CASE INVOKE_FUNC
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "InvokeKind = Function")
         CASE INVOKE_PROPERTYGET
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "InvokeKind = Get property")
         CASE INVOKE_PROPERTYPUT
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "InvokeKind = Put property")
         CASE INVOKE_PROPERTYPUTREF
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "InvokeKind = PutRef property")
      END SELECT
      ' // Calling convention
      SELECT CASE pFuncDesc->callconv
         CASE CC_FASTCALL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = FASTCALL")
         CASE CC_CDECL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = CDECL")
         CASE CC_MACPASCAL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = MACPASCAL")
         CASE CC_STDCALL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = STDCALL")
         CASE CC_FPFASTCALL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = FPFASTCALL")
         CASE CC_SYSCALL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = SYSCALL")
         CASE CC_MPWCDECL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = MPWCDECL")
         CASE CC_MPWPASCAL
            TreeView_AddItem(hTreeView, hSubNode2, NULL, "Calling convention = MPWPASCAL")
      END SELECT

      ' // More general information
      IF pFuncDesc->cParamsOpt THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Number of optional variant parameters = " & WSTR(pFuncDesc->cParamsOpt))
      IF pFuncDesc->cScodes THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Count of permitted return values = " & WSTR(pFuncDesc->cScodes))
      IF pFuncDesc->wFuncFlags THEN TreeView_AddItem(hTreeView, hSubNode2, NULL, "Attributes = " & WSTR(pFuncDesc->wFuncFlags)& " [&H" & HEX(pFuncDesc->wFuncFlags, 8) & "]" & TLB_FuncFlagsToStr(pFuncDesc->wFuncFlags))
      ' // Return type
      IF pFuncDesc->elemdescFunc.tdesc.vt = VT_USERDEFINED THEN
         ' // If it is a user defined type, retrieve its name
         hr = pTypeInfo->GetRefTypeInfo(pFuncDesc->elemdescFunc.tdesc.hreftype, @pRefTypeInfo)
         IF hr = S_OK AND pRefTypeInfo <> NULL THEN
            cbstrName.Clear
            hr = pRefTypeInfo->GetDocumentation(-1, @cbstrName, NULL, NULL, NULL)
            hr = pRefTypeInfo->GetTypeAttr(@pReturnTypeAttr)
            IF hr = S_OK AND pReturnTypeAttr <> NULL THEN
               TreeView_AddItem(hTreeView, hSubNode2, NULL, "Return type typeKind = " & TLB_TypeKindToStr(pReturnTypeAttr->typekind))
               pRefTypeInfo->ReleaseTypeAttr(pReturnTypeAttr)
               pReturnTypeAttr = NULL
            END IF
            IF pRefTypeInfo THEN pRefTypeInfo->Release
         END IF
      ELSEIF pFuncDesc->elemdescFunc.tdesc.vt = VT_PTR THEN
         ' // Pointer to a TYPEDESC structure
         ptdesc = pFuncDesc->elemdescFunc.tdesc.lptdesc
         DO
            SELECT CASE ptdesc->vt
               ' // If it is a pointer, do it again
               CASE VT_PTR
                  ptdesc = ptdesc->lptdesc
               CASE VT_USERDEFINED
                  ' // Retrieve the name of the user defined type
                  hr = pTypeInfo->GetRefTypeInfo(ptdesc->hreftype, @pRefTypeInfo)
                  IF hr = S_OK AND pRefTypeInfo <> NULL THEN
                     cbstrName.Clear
                     hr = pRefTypeInfo->GetDocumentation(-1, @cbstrName, NULL, NULL, NULL)
                     hr = pRefTypeInfo->GetTypeAttr(@pReturnTypeAttr)
                     IF hr = S_OK AND pReturnTypeAttr <> NULL THEN
                        TreeView_AddItem(hTreeView, hSubNode2, NULL, "Return type typeKind = " & TLB_TypeKindToStr(pReturnTypeAttr->typekind))
                        pRefTypeInfo->ReleaseTypeAttr(pReturnTypeAttr)
                        pReturnTypeAttr = NULL
                     END IF
                     IF pRefTypeInfo THEN pRefTypeInfo->Release
                  END IF
                  EXIT DO
               CASE ELSE
                  ' // Get the equivalent type
                  cbstrName = TLB_VarTypeToConstant(ptdesc->vt)
                  EXIT DO
            END SELECT
         LOOP
      ELSE
         ' // Get the equivalent type
         cbstrName = TLB_VarTypeToConstant(pFuncDesc->elemdescFunc.tdesc.vt)
      END IF
      TreeView_AddItem(hTreeView, hSubNode2, NULL, "Return type = " & cbstrName)
      ' // Parameters
      IF pFuncDesc->cParams THEN this.GetParameters(pTypeInfo, pFuncDesc, hTreeView, hSubNode2)
      ' // Expand the nodes
'      TreeView_Expand hTreeView, hSubNode2, TVE_EXPAND
      TreeView_Expand(hTreeView, hSubNode, TVE_EXPAND)
'      TreeView_Expand hTreeView, hParamsNode, TVE_EXPAND
      ' // Release the FUNCDESC structure
      pTypeInfo->ReleaseFuncDesc(pFuncDesc)
      pFuncDesc = NULL
   NEXT

   IF pFuncDesc THEN pTypeInfo->ReleaseFuncDesc(pFuncDesc)

   ' // Just to satisfy the compiler rules; it has no useful meaning
   FUNCTION = hr

END FUNCTION
' =====================================================================================


[José Roca]

One of the members of the FUNDESC structure, cParams, contains the number of parameters of each function or method. Parameters can be of any kind of data type and be passed by value or by reference. And so the fun continues!

Code Select Expand


' =====================================================================================
' Retrieve information about the parameters
' =====================================================================================
FUNCTION CParseTypeLib.GetParameters (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL pFuncDesc AS FUNCDESC PTR, BYVAL hTreeView AS HWND, BYVAL hSubNode2 AS HTREEITEM) AS HRESULT

   DIM hr AS HRESULT                       ' // HRESULT
   DIM y AS LONG                           ' // Loop counter
   DIM hParamsNode AS HTREEITEM            ' // Parameters node
   DIM hParamNameNode AS HTREEITEM         ' // Parameter name node
   DIM cNames AS DWORD                     ' // Number of names returned by ITypeInfo.GetNames
   DIM pParam AS ELEMDESC PTR              ' // Pointer to an array of parameters
   DIM wFlags AS WORD                      ' // Parameter flags
   DIM cbstrParamName AS CBSTR             ' // Parameter name
   DIM pParamTypeAttr AS TYPEATTR PTR      ' // Referenced TYPEATTR structure
   DIM pReturnTypeAttr AS TYPEATTR PTR     ' // Referenced TYPEATTR structure
   DIM cbstrVarType AS CBSTR               ' // Variable type
   DIM cbstrTypeKind AS CBSTR              ' // Type kind
   DIM cbstrFBKeyword AS CBSTR             ' // FB keyword
   DIM cbstrFBSyntax AS CBSTR              ' // FB syntax
   DIM wIndirectionLevel AS WORD           ' // Indirection level
   DIM pRefTypeInfo AS Afx_ITypeInfo PTR   ' // Referenced TypeInfo interface
   DIM ptdesc AS TYPEDESC PTR              ' // Pointer to a TYPEDESC structure

   hParamsNode = TreeView_AddItem(hTreeView, hSubNode2, NULL, "Number of parameters = " & WSTR(pFuncDesc->cParams))
   ' ----------------------------------------------------------------------------------
   ' Gets the name of all the parameters.
   ' The first one is the name of the function.
   ' If the member ID identifies a property that is implemented with property functions,
   ' the property name is returned. For property get functions, the names of the function
   ' and its parameters are always returned.
   ' For property put and put reference functions, the right side of the assignment is
   ' unnamed. If cMaxNames is less than is required to return all of the names of the
   ' parameters of a function, then only the names of the first cMaxNames-1 parameters
   ' are returned. The names of the parameters are returned in the array in the same
   ' order that they appear elsewhere in the interface (for example, the same order in
   ' the parameter array associated with the FUNCDESC enumeration).
   ' ----------------------------------------------------------------------------------
   REDIM rgbstrNames(pFuncDesc->cParams) AS AFX_BSTR
   hr = pTypeInfo->GetNames(pFuncDesc->memid, @rgbstrNames(0), pFuncDesc->cParams + 1, @cNames)
   IF hr = S_OK THEN
      ' // Pointer to an ELEMDESC structure
      pParam = pFuncDesc->lprgelemdescParam
      ' // Retrieves information about the parameters
      FOR y = 0 TO pFuncDesc->cParams - 1
         cbstrVarType.Clear : cbstrTypeKind.Clear : cbstrFBKeyword.Clear
         ' // Attributes
         wFlags = pParam[y].paramdesc.wParamFlags
         cbstrParamName = rgbstrNames(y + 1)
         IF LEN(cbstrParamName) = 0 THEN
            IF y = pFuncDesc->cParams - 1 THEN
               cbstrParamName = "RHS"
            ELSE
               cbstrParamName = "prm" & WSTR(y + 1)
            END IF
         END IF
         hParamNameNode = TreeView_AddItem(hTreeView, hParamsNode, NULL, cbstrParamName)
         TreeView_AddItem(hTreeView, hParamNameNode, NULL, "Attributes = " & WSTR(wFlags) & " [&H" & HEX(wFlags, 8) & "] " & TLB_ParamflagsToStr(wFlags))
         wIndirectionLevel = 0
         IF pParam[y].tdesc.vt = VT_USERDEFINED THEN
            ' // If it is a user defined type, retrieve its name
            hr = pTypeInfo->GetRefTypeInfo(pParam[y].tdesc.hreftype, @pRefTypeInfo)
            IF hr = S_OK AND pRefTypeInfo <> NULL THEN
               cbstrVarType.Clear
               hr = pRefTypeInfo->GetDocumentation(-1, @cbstrVarType, NULL, NULL, NULL)
               hr = pRefTypeInfo->GetTypeAttr(@pParamTypeAttr)
               IF hr = S_OK AND pParamTypeAttr <> NULL THEN
                  IF pParamTypeAttr->typekind = TKIND_ALIAS THEN
                     cbstrTypeKind = TLB_TypeKindToStr(pParamTypeAttr->typekind) & " | " & TLB_VarTypeToConstant(pParamTypeAttr->tdescalias.vt)
                  ELSE
                     cbstrTypeKind = TLB_TypeKindToStr(pParamTypeAttr->typekind)
                  END IF
                  TreeView_AddItem(hTreeView, hParamNameNode, NULL, "TypeKind = " & cbstrTypeKind)
                  pRefTypeInfo->ReleaseTypeAttr(pParamTypeAttr)
                  pParamTypeAttr = NULL
               END IF
               IF pRefTypeInfo THEN pRefTypeInfo->Release
            END IF
         ELSEIF pParam[y].tdesc.vt = VT_PTR THEN
            ' // Pointer to a TYPEDESC structure
            ptdesc = pParam[y].tdesc.lptdesc
            wIndirectionLevel = 1
            DO
               SELECT CASE ptdesc->vt
                  ' // If it is a pointer, do it again
                  CASE VT_PTR
                     wIndirectionLevel += 1
                     ptdesc = ptdesc->lptdesc
                  CASE VT_USERDEFINED
                     ' // Retrieve the name of the user defined type
                     hr = pTypeInfo->GetRefTypeInfo(ptdesc->hreftype, @pRefTypeInfo)
                     IF hr = S_OK AND pRefTypeInfo <> NULL THEN
                        cbstrVarType.Clear
                        hr = pRefTypeInfo->GetDocumentation(-1, @cbstrVarType, NULL, NULL, NULL)
                        hr = pRefTypeInfo->GetTypeAttr(@pParamTypeAttr)
                        IF hr = S_OK AND pParamTypeAttr <> NULL THEN
                           IF pParamTypeAttr->typekind = TKIND_ALIAS THEN
                              cbstrTypeKind = TLB_TypeKindToStr(pParamTypeAttr->typekind) & " | " & TLB_VarTypeToConstant(pParamTypeAttr->tdescalias.vt)
                           ELSE
                              cbstrTypeKind = TLB_TypeKindToStr(pParamTypeAttr->typekind)
                           END IF
                           TreeView_AddItem(hTreeView, hParamNameNode, NULL, "TypeKind = " & cbstrTypeKind)
                           pRefTypeInfo->ReleaseTypeAttr(pParamTypeAttr)
                           pParamTypeAttr = NULL
                        END IF
                        IF pRefTypeInfo THEN pRefTypeInfo->Release
                     END IF
                     EXIT DO
                  CASE ELSE
                     ' // Get the equivalent type
                     cbstrVarType = TLB_VarTypeToConstant(ptdesc->vt)
                     cbstrFBKeyword = TLB_VarTypeToKeyword(ptdesc->vt)
                     EXIT DO
               END SELECT
            LOOP
         ELSE
            ' // Get the equivalent type
            cbstrVarType = TLB_VarTypeToConstant(pParam[y].tdesc.vt)
            cbstrFBKeyword = TLB_VarTypeToKeyword(pParam[y].tdesc.vt)
            ' // Increment indirection level to pointers
            IF cbstrTypeKind = "TKIND_INTERFACE" OR cbstrTypeKind = "TKIND_DISPATCH" OR cbstrTypeKind = "TKIND_COCLASS" THEN wIndirectionLevel += 1
            IF cbstrVarType = "VT_SAFEARRAY" THEN wIndirectionLevel += 1
         END IF
         TreeView_AddItem(hTreeView, hParamNameNode, NULL, "Indirection level = " & WSTR(wIndirectionLevel))
         TreeView_AddItem(hTreeView, hParamNameNode, NULL, "VarType = " & cbstrVarType)
         ' // Add a prefix to structures that begin with an underscore
'         IF LEFT$(cbstrVarType, 1) = "_" THEN
'            IF cbstrTypeKind = "TKIND_RECORD" OR cbstrTypeKind = "TKIND_UNION" THEN cbstrVarType = "tag" & cbstrVarType
'         END IF
'         ' // Use generic data types for enums and interfaces
         IF cbstrFBKeyword = "" THEN cbstrFBKeyword = cbstrVarType
         IF cbstrTypeKind = "TKIND_ALIAS | VT_PTR" THEN cbstrFBKeyword = "VOID"
         IF cbstrTypeKind = "TKIND_ENUM" THEN cbstrFBKeyword = cbstrVarType
         IF cbstrTypeKind = "TKIND_UNKNOWN" THEN cbstrFBKeyword = "IUnknown"
         IF cbstrTypeKind = "TKIND_DISPATCH" THEN cbstrFBKeyword = "IDispatch"
         ' // Decide if to pass the parameter by value or by reference
         cbstrFBSyntax = ""
         SELECT CASE **cbstrVarType
            CASE "VT_LPSTR"
               cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS ZSTRING PTR"
            CASE "VT_LPWSTR"
               cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS WSTRING PTR"
            CASE "VT_BSTR"
               cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS BSTR"
            CASE "VT_UNKNOWN"
               IF wIndirectionLevel = 2 THEN
                  cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IUnknown PTR PTR"
               ELSE
                  IF (wFlags AND PARAMFLAG_FOUT) = PARAMFLAG_FOUT THEN
                     cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IUnknown PTR PTR"
                  ELSE
                     cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IUnknown PTR"
                  END IF
               END IF
            CASE "VT_DISPATCH"
               IF wIndirectionLevel = 2 THEN
                  cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IDispatch PTR PTR"
               ELSE
                  IF (wFlags AND PARAMFLAG_FOUT) = PARAMFLAG_FOUT THEN
                     cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IDispatch PTR PTR"
                  ELSE
                     cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS IDispatch PTR"
                  END IF
               END IF
            CASE "VT_VOID"
               IF wIndirectionLevel = 2 THEN
                  cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS VOID PTR PTR"
               ELSE
                  cbstrFBSyntax = "BYVAL " & cbstrParamName & " AS VOID PTR"
               END IF
            CASE ELSE
               IF cbstrTypeKind = "TKIND_INTERFACE" OR cbstrTypeKind = "TKIND_DISPATCH" OR cbstrTypeKind = "TKIND_COCLASS" OR _
                  cbstrVarType = "IFont" OR cbstrVarType = "IFontDisp" OR cbstrVarType = "IPicture" OR cbstrVarType = "IPictureDisp" THEN
                  IF wIndirectionLevel = 2 THEN
                     cbstrFBSyntax = "BYVAL " & **cbstrParamName & " AS " & **cbstrFBKeyword & " PTR PTR"
                  ELSE
                     cbstrFBSyntax = "BYVAL " & **cbstrParamName & " AS " & **cbstrFBKeyword & " PTR"
                  END IF
               ELSE
                  IF wIndirectionLevel = 0 THEN
                     cbstrFBSyntax = "BYVAL " & **cbstrParamName & " AS " & **cbstrFBKeyword
                  ELSE
                     cbstrFBSyntax = "BYVAL " & **cbstrParamName & " AS " & **cbstrFBKeyword & " PTR"
                  END IF
               END IF
         END SELECT
'         IF (wFlags AND PARAMFLAG_FOPT) = PARAMFLAG_FOPT THEN cbstrFBSyntax = cbstrFBSyntax & " = " & ...  ' // Optional parameter
         TreeView_AddItem(hTreeView, hParamNameNode, NULL, "FB syntax = " & cbstrFBSyntax)
         TreeView_Expand(hTreeView, hParamNameNode, TVE_EXPAND)
      NEXT
   END IF

   ' // DO NOT free the BSTRs; they are owned by the callee
   ' // Free the BSTRs of the array
'   FOR i AS LONG = LBOUND(rgbstrNames) TO UBOUND(rgbstrNames)
'      IF rgbstrNames(i) THEN SysFreeString(rgbstrNames(i))
'   NEXT

   ' // Just to satisfy the compiler rules; it has no useful meaning
   RETURN hr

END FUNCTION
' =====================================================================================


[José Roca]

A number of helper functions have been used to translate numeric values to more descriptive information:

Code Select Expand


' ========================================================================================
' Converts LibFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_LibFlagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN FUNCTION = " [None]" : EXIT FUNCTION
   IF (wFlags AND LIBFLAG_FRESTRICTED) = LIBFLAG_FRESTRICTED THEN strFlags += " [Restricted]"
   IF (wFlags AND LIBFLAG_FCONTROL) = LIBFLAG_FCONTROL THEN strFlags += " [Control]"
   IF (wFlags AND LIBFLAG_FHIDDEN) = LIBFLAG_FHIDDEN THEN strFlags += " [Hidden]"
   IF (wFlags AND LIBFLAG_FHASDISKIMAGE) = LIBFLAG_FHASDISKIMAGE THEN strFlags += " [HasDiskImage]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts InterfaceFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_InterfaceFlagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN FUNCTION = " [None]" : EXIT FUNCTION
   IF (wFlags AND TYPEFLAG_FAPPOBJECT) = TYPEFLAG_FAPPOBJECT THEN strFlags += " [Application]"
   IF (wFlags AND TYPEFLAG_FCANCREATE) = TYPEFLAG_FCANCREATE THEN strFlags += " [Cancreate]"
   IF (wFlags AND TYPEFLAG_FLICENSED) = TYPEFLAG_FLICENSED THEN strFlags += " [Licensed]"
   IF (wFlags AND TYPEFLAG_FPREDECLID) = TYPEFLAG_FPREDECLID THEN strFlags += " [Predefined]"
   IF (wFlags AND TYPEFLAG_FHIDDEN) = TYPEFLAG_FHIDDEN THEN strFlags += " [Hidden]"
   IF (wFlags AND TYPEFLAG_FCONTROL) = TYPEFLAG_FCONTROL THEN strFlags += " [Control]"
   IF (wFlags AND TYPEFLAG_FDUAL) = TYPEFLAG_FDUAL THEN strFlags += " [Dual]"
   IF (wFlags AND TYPEFLAG_FNONEXTENSIBLE) = TYPEFLAG_FNONEXTENSIBLE THEN strFlags += " [Nonextensible]"
   IF (wFlags AND TYPEFLAG_FOLEAUTOMATION) = TYPEFLAG_FOLEAUTOMATION THEN strFlags += " [Oleautomation]"
   IF (wFlags AND TYPEFLAG_FRESTRICTED) = TYPEFLAG_FRESTRICTED THEN strFlags += " [Restricted]"
   IF (wFlags AND TYPEFLAG_FAGGREGATABLE) = TYPEFLAG_FAGGREGATABLE THEN strFlags += " [Aggregatable]"
   IF (wFlags AND TYPEFLAG_FREPLACEABLE) = TYPEFLAG_FREPLACEABLE THEN strFlags += " [Replaceable]"
   IF (wFlags AND TYPEFLAG_FDISPATCHABLE) = TYPEFLAG_FDISPATCHABLE THEN strFlags += " [Dispatchable]"
   IF (wFlags AND TYPEFLAG_FREVERSEBIND) = TYPEFLAG_FREVERSEBIND THEN strFlags += " [Reversebind]"
   IF (wFlags AND TYPEFLAG_FPROXY) = TYPEFLAG_FPROXY THEN strFlags += " [Proxy]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts ImplTypeFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_ImplTypeFlagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN FUNCTION = " [None]" : EXIT FUNCTION
   IF (wFlags AND IMPLTYPEFLAG_FDEFAULT) = IMPLTYPEFLAG_FDEFAULT THEN strFlags += " [Default]"
   IF (wFlags AND IMPLTYPEFLAG_FSOURCE) = IMPLTYPEFLAG_FSOURCE THEN strFlags += " [Source]"
   IF (wFlags AND IMPLTYPEFLAG_FRESTRICTED) = IMPLTYPEFLAG_FRESTRICTED THEN strFlags += " [Restricted]"
   IF (wFlags AND IMPLTYPEFLAG_FDEFAULTVTABLE) = IMPLTYPEFLAG_FDEFAULTVTABLE THEN strFlags += " [Default VTable]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts FuncFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_FuncFlagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN FUNCTION = " [None]" : EXIT FUNCTION
   IF (wFlags AND FUNCFLAG_FRESTRICTED) = FUNCFLAG_FRESTRICTED THEN strFlags += " [Restricted]"
   IF (wFlags AND FUNCFLAG_FSOURCE) = FUNCFLAG_FSOURCE THEN strFlags += " [Source]"
   IF (wFlags AND FUNCFLAG_FBINDABLE) = FUNCFLAG_FBINDABLE THEN strFlags += " [Bindable]"
   IF (wFlags AND FUNCFLAG_FREQUESTEDIT) = FUNCFLAG_FREQUESTEDIT THEN strFlags += " [RequestEdit]"
   IF (wFlags AND FUNCFLAG_FDISPLAYBIND) = FUNCFLAG_FDISPLAYBIND THEN strFlags += " [DisplayBind]"
   IF (wFlags AND FUNCFLAG_FDEFAULTBIND) = FUNCFLAG_FDEFAULTBIND THEN strFlags += " [DefaultBind]"
   IF (wFlags AND FUNCFLAG_FHIDDEN) = FUNCFLAG_FHIDDEN THEN strFlags += " [Hidden]"
   IF (wFlags AND FUNCFLAG_FUSESGETLASTERROR) = FUNCFLAG_FUSESGETLASTERROR THEN strFlags += " [UsesGetLastError]"
   IF (wFlags AND FUNCFLAG_FDEFAULTCOLLELEM) = FUNCFLAG_FDEFAULTCOLLELEM THEN strFlags += " [DefaultCollELem]"
   IF (wFlags AND FUNCFLAG_FUIDEFAULT) = FUNCFLAG_FUIDEFAULT THEN strFlags += " [UserInterfaceDefault]"
   IF (wFlags AND FUNCFLAG_FNONBROWSABLE) = FUNCFLAG_FNONBROWSABLE THEN strFlags += " [NonBrowsable]"
   IF (wFlags AND FUNCFLAG_FREPLACEABLE) = FUNCFLAG_FREPLACEABLE THEN strFlags += " [Replaceable]"
   IF (wFlags AND FUNCFLAG_FIMMEDIATEBIND) = FUNCFLAG_FIMMEDIATEBIND THEN strFlags += " [InmediateBind]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts ParamFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_ParamflagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN FUNCTION = " [None]" : EXIT FUNCTION
   IF (wFlags AND PARAMFLAG_FOPT) = PARAMFLAG_FOPT THEN strFlags += " [opt]"
   IF (wFlags AND PARAMFLAG_FRETVAL) = PARAMFLAG_FRETVAL THEN strFlags += " [retval]"
   IF (wFlags AND PARAMFLAG_FIN) = PARAMFLAG_FIN THEN strFlags += " [in]"
   IF (wFlags AND PARAMFLAG_FOUT) = PARAMFLAG_FOUT THEN strFlags += " [out]"
   IF (wFlags AND PARAMFLAG_FLCID) = PARAMFLAG_FLCID THEN strFlags += " [lcid]"
   IF (wFlags AND PARAMFLAG_FHASDEFAULT) = PARAMFLAG_FHASDEFAULT THEN strFlags += " [hasdefault]"
   IF (wFlags AND PARAMFLAG_FHASCUSTDATA) = PARAMFLAG_FHASCUSTDATA THEN strFlags += " [hascustdata]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts VarFlags to a descriptive string.
' ========================================================================================
FUNCTION TLB_VarFlagsToStr (BYVAL wFlags AS WORD) AS STRING
   DIM strFlags AS STRING
   IF wFlags = 0 THEN strFlags = " [None]"
   IF (wFlags AND VARFLAG_FREADONLY) = VARFLAG_FREADONLY THEN strFlags += " [ReadOnly]"
   IF (wFlags AND VARFLAG_FSOURCE) = VARFLAG_FSOURCE THEN strFlags += " [Source]"
   IF (wFlags AND VARFLAG_FBINDABLE) = VARFLAG_FBINDABLE THEN strFlags += " [Bindable]"
   IF (wFlags AND VARFLAG_FREQUESTEDIT) = VARFLAG_FREQUESTEDIT THEN strFlags += " [RequestEdit]"
   IF (wFlags AND VARFLAG_FDISPLAYBIND) = VARFLAG_FDISPLAYBIND THEN strFlags += " [DisplayBind]"
   IF (wFlags AND VARFLAG_FDEFAULTBIND) = VARFLAG_FDEFAULTBIND THEN strFlags += " [DefaultBind]"
   IF (wFlags AND VARFLAG_FHIDDEN) = VARFLAG_FHIDDEN THEN strFlags += " [Hidden]"
   IF (wFlags AND VARFLAG_FRESTRICTED) = VARFLAG_FRESTRICTED THEN strFlags += " [Restricted]"
   IF (wFlags AND VARFLAG_FDEFAULTCOLLELEM) = VARFLAG_FDEFAULTCOLLELEM THEN strFlags += " [DefaultCollElem]"
   IF (wFlags AND VARFLAG_FUIDEFAULT) = VARFLAG_FUIDEFAULT THEN strFlags += " [User interface default]"
   IF (wFlags AND VARFLAG_FNONBROWSABLE) = VARFLAG_FNONBROWSABLE THEN strFlags += " [NoBrowsable]"
   IF (wFlags AND VARFLAG_FREPLACEABLE) = VARFLAG_FREPLACEABLE THEN strFlags += " [Replaceable]"
   IF (wFlags AND VARFLAG_FIMMEDIATEBIND) = VARFLAG_FIMMEDIATEBIND THEN strFlags += " [ImmediateBind]"
   FUNCTION = strFlags
END FUNCTION
' ========================================================================================

' ========================================================================================
' Converts a type kind to a descriptive string.
' ========================================================================================
FUNCTION TLB_TypeKindToStr (BYVAL dwTypeKind AS DWORD) AS STRING
   DIM strType AS STRING
   SELECT CASE dwTypeKind
      CASE TKIND_ENUM      : strType = "TKIND_ENUM"
      CASE TKIND_RECORD    : strType = "TKIND_RECORD"
      CASE TKIND_MODULE    : strType = "TKIND_MODULE"
      CASE TKIND_INTERFACE : strType = "TKIND_INTERFACE"
      CASE TKIND_DISPATCH  : strType = "TKIND_DISPATCH"
      CASE TKIND_COCLASS   : strType = "TKIND_COCLASS"
      CASE TKIND_ALIAS     : strType = "TKIND_ALIAS"
      CASE TKIND_UNION     : strType = "TKIND_UNION"
   END SELECT
   FUNCTION = strType
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the VarType.
' ========================================================================================
FUNCTION TLB_VarTypeToStr (BYVAL VarType AS LONG, BYVAL fReturnType AS LONG = 0) AS STRING
   DIM s AS STRING
   SELECT CASE VarType
      CASE     0 : s = "VT_EMPTY"
      CASE     1 : s = "VT_NULL"
      CASE     2 : s = "VT_I2 <Short>"
      CASE     3 : s = "VT_I4 <Long>"
      CASE     4 : s = "VT_R4 <Single>"
      CASE     5 : s = "VT_R8 <Double>"
      CASE     6 : s = "VT_CY <CY>"
      CASE     7 : s = "VT_DATE <DATE_>"
      CASE     8 : s = "VT_BSTR"
      CASE     9 : s = "VT_DISPATCH <IDispatch>"
      CASE    10 : s = "VT_ERROR <SCode>"
      CASE    11 : s = "VT_BOOL <Bool>"
      CASE    12 : s = "VT_VARIANT <Variant>"
      CASE    13 : s = "VT_UNKNOWN <IUnknown>"
      CASE    14 : s = "VT_DECIMAL <DECIMAL>"
      CASE    16 : s = "VT_I1 <Byte>"
      CASE    17 : s = "VT_UI1 <UByte>"
      CASE    18 : s = "VT_UI2 <Short>"
      CASE    19 : s = "VT_UI4 <Ulong>"
      CASE    20 : s = "VT_I8 <LongInt>"
      CASE    21 : s = "VT_UI8 <ULongInt>"
      CASE    22 : s = "VT_INT <Int_>"
      CASE    23 : s = "VT_UINT <Uint>"
      CASE    24 :
         IF fReturnType THEN
            s = "VT_VOID <void>"
         ELSE
            s = "VT_VOID <void>"
         END IF
      CASE    25 : s = "VT_HRESULT <HRESULT>"
      CASE    26 : s = "VT_PTR <PTR>"
      CASE    27 : s = "VT_SAFEARRAY <SAFEARRAY>"
      CASE    28 : s = "VT_CARRAY"
      CASE    29 : s = "VT_USERDEFINED"
      CASE    30 : s = "VT_LPSTR"
      CASE    31 : s = "VT_LPWSTR"
      CASE    36 : s = "VT_RECORD"
      CASE    64 : s = "VT_FILETIME <FILETIME>"
      CASE    65 : s = "VT_BLOB <BLOB>"
      CASE    66 : s = "VT_STREAM <IStream PTR>"
      CASE    67 : s = "VT_STORAGE <IStorage PTR>"
      CASE    68 : s = "VT_STREAMED_OBJECT"
      CASE    69 : s = "VT_STORED_OBJECT"
      CASE    70 : s = "VT_BLOB_OBJECT"
      CASE    71 : s = "VT_CF"
      CASE    72 : s = "VT_CLSID <Guid>"
      CASE  4096 : s = "VT_VECTOR"
      CASE  8192 : s = "VT_ARRAY"
      CASE 16384 : s = "VT_BYREF"
      CASE 32768 : s = "VT_RESERVED"
   END SELECT
   FUNCTION = s
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the VarType
' ========================================================================================
FUNCTION TLB_VarTypeToConstant (BYVAL VarType AS LONG) AS STRING
   DIM s AS STRING
   SELECT CASE VarType
      CASE     0 : s = "VT_EMPTY"
      CASE     1 : s = "VT_NULL"
      CASE     2 : s = "VT_I2"
      CASE     3 : s = "VT_I4"
      CASE     4 : s = "VT_R4"
      CASE     5 : s = "VT_R8"
      CASE     6 : s = "VT_CY"
      CASE     7 : s = "VT_DATE"
      CASE     8 : s = "VT_BSTR"
      CASE     9 : s = "VT_DISPATCH"
      CASE    10 : s = "VT_ERROR"
      CASE    11 : s = "VT_BOOL"
      CASE    12 : s = "VT_VARIANT"
      CASE    13 : s = "VT_UNKNOWN"
      CASE    14 : s = "VT_DECIMAL"
      CASE    16 : s = "VT_I1"
      CASE    17 : s = "VT_UI1"
      CASE    18 : s = "VT_UI2"
      CASE    19 : s = "VT_UI4"
      CASE    20 : s = "VT_I8"
      CASE    21 : s = "VT_UI8"
      CASE    22 : s = "VT_INT"
      CASE    23 : s = "VT_UINT"
      CASE    24 : s = "VT_VOID"
      CASE    25 : s = "VT_HRESULT"
      CASE    26 : s = "VT_PTR"
      CASE    27 : s = "VT_SAFEARRAY"
      CASE    28 : s = "VT_CARRAY"
      CASE    29 : s = "VT_USERDEFINED"
      CASE    30 : s = "VT_LPSTR"
      CASE    31 : s = "VT_LPWSTR"
      CASE    36 : s = "VT_RECORD"
      CASE    64 : s = "VT_FILETIME"
      CASE    65 : s = "VT_BLOB"
      CASE    66 : s = "VT_STREAM"
      CASE    67 : s = "VT_STORAGE"
      CASE    68 : s = "VT_STREAMED_OBJECT"
      CASE    69 : s = "VT_STORED_OBJECT"
      CASE    70 : s = "VT_BLOB_OBJECT"
      CASE    71 : s = "VT_CF"
      CASE    72 : s = "VT_CLSID"
      CASE  4096 : s = "VT_VECTOR"
      CASE  8192 : s = "VT_ARRAY"
      CASE 16384 : s = "VT_BYREF"
      CASE 32768 : s = "VT_RESERVED"
   END SELECT
   FUNCTION = s
END FUNCTION
' ========================================================================================

' ========================================================================================
' Returns the VarType as a keyword
' ========================================================================================
FUNCTION TLB_VarTypeToKeyword (BYVAL VarType AS LONG, BYVAL cElements AS WORD = 0) AS STRING
   ' Note: VT_I1 is an array of bytes; translate it to a fixed string
   DIM s AS STRING
   SELECT CASE VarType
      CASE     0 : s = "VOID"                              ' VT_EMPTY
      CASE     1 : s = "VOID"                              ' VT_NULL
      CASE     2 : s = "SHORT"                             ' VT_I2
      CASE     3 : s = "LONG"                              ' VT_I4
      CASE     4 : s = "SINGLE"                            ' VT_R4
      CASE     5 : s = "DOUBLE"                            ' VT_R8
      CASE     6 : s = "CY"                                ' VT_CY
      CASE     7 : s = "DATE_"                             ' VT_DATE
      CASE     8 : s = "BSTR"                              ' VT_BSTR
      CASE     9 : s = "IDispatch"                         ' VT_DISPATCH
      CASE    10 : s = "SCODE"                             ' VT_ERROR
      CASE    11 : s = "BOOL"                              ' VT_BOOL
      CASE    12 : s = "VARIANT"                           ' VT_VARIANT
      CASE    13 : s = "IUnknown"                          ' VT_UNKNOWN
      CASE    14 : s = "DECIMAL"                           ' VT_DECIMAL
      CASE 16, 17                                          ' VT_I1, VT_UI1
'         IF cElements THEN
'            s = "WSTRING * " & STR(cElements)              ' Byte array
'         ELSE
'            s = "BYTE"
'         END IF
         IF cElements THEN
            s = "(0 TO " & STR(cElements) & " AS " & IIF&(VarType = 16, "BYTE", "UBYTE") & ")"
         ELSE
            s = IIF&(VarType = 16, "BYTE", "UBYTE")
         END IF
      CASE    18 : s = "USHORT"                            ' VT_UI2
      CASE    19 : s = "ULONG"                             ' VT_UI4
      CASE    20 : s = "LONGINT"                           ' VT_I8
      CASE    21 : s = "ULONGINT"                          ' VT_UI8
      CASE    22 : s = "INT_"                              ' VT_INT
      CASE    23 : s = "UINT"                              ' VT_UINT
      CASE    24 : s = "VOID"                              ' VT_VOID
      CASE    25 : s = "HRESULT"                           ' VT_HRESULT
      CASE    26 : s = "PTR"                               ' VT_PTR
      CASE    27 : s = "SAFEARRAY"                         ' VT_SAFEARRAY
      CASE    28 : s = "VOID"                              ' VT_CARRAY
      CASE    29 : s = "VOID"                              ' VT_USERDEFINED
      CASE    30 : s = "ZTRING"                            ' VT_LPSTR
      CASE    31 : s = "WSTRING"                           ' VT_LPWSTR
      CASE    36 : s = "VOID"                              ' VT_RECORD
      CASE    64 : s = "FILETIME"                          ' VT_FILETIME
      CASE    65 : s = "BLOB"                              ' VT_BLOB
      CASE    66 : s = "IStream"                           ' VT_STREAM
      CASE    67 : s = "IStorage"                          ' VT_STORAGE
      CASE    68 : s = "VOID"                              ' VT_STREAMED_OBJECT
      CASE    69 : s = "VOID"                              ' VT_STORED_OBJECT
      CASE    70 : s = "VOID"                              ' VT_BLOB_OBJECT
      CASE    71 : s = "VOID"                              ' VT_CF
      CASE    72 : s = "CLSID"                             ' VT_CLSID
      CASE  4096 : s = "VOID"                              ' VT_VECTOR
      CASE  8192 : s = "VOID"                              ' VT_ARRAY
      CASE 16384 : s = "VT_BYREF"
      CASE 32768 : s = "VT_RESERVED"
   END SELECT
   FUNCTION = s
END FUNCTION
' ========================================================================================

' ========================================================================================
' Gets the appropiate member name of the variant union for byref parameters.
' Note: VT_HRESULT isn't an automation compatible type, but the CreatePartnershipComplete
' event of Windows Media Player has a parameter of this type.
' ========================================================================================
FUNCTION TLB_GetUnionMemberName (BYVAL vt AS LONG) AS STRING
   DIM strvt AS STRING
   SELECT CASE vt
      CASE VT_I1, VT_UI1 : strvt = "pbVal"
      CASE VT_I2 : strvt = "piVal"
      CASE VT_I4, VT_INT, VT_UI4, VT_UINT, VT_HRESULT : strvt = "plVal"
      CASE VT_R4 : strvt = "pfltVal"
      CASE VT_R8, VT_I8, VT_UI8 : strvt = "pdblVal"
      CASE VT_BOOL : strvt = "pboolVal"
      CASE VT_ERROR : strvt = "pscode"
      CASE VT_CY : strvt = "pcyVal"
      CASE VT_DATE : strvt = "pdate"
      CASE VT_BSTR : strvt = "pbstrVal"
      CASE VT_UNKNOWN : strvt = "ppunkVal"
      CASE VT_DISPATCH : strvt = "ppdispVal"
      CASE VT_ARRAY : strvt = "psArray"
      CASE VT_VARIANT : strvt = "pVariant"
      CASE ELSE : strvt = "plVal"
   END SELECT
   FUNCTION = strvt
END FUNCTION
' ========================================================================================


[José Roca]

And others to get information from the registry and to get the names of implemented and inherited interfaces, and the base class.

Code Select Expand


' ========================================================================================
' Retrieves the implemented interface.
' ========================================================================================
FUNCTION TLB_GetImplementedInterface (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL idx AS LONG = 0) AS CBSTR

   DIM hr            AS HRESULT             ' // HRESULT
   DIM pRefType      AS HREFTYPE            ' // Address to a referenced type description
   DIM pImplTypeInfo AS Afx_ITypeInfo PTR   ' // Implemented interface type info
   DIM bstrName      AS AFX_BSTR            ' // Interface's name (unicode)

   hr = pTypeInfo->GetRefTypeOfImplType(idx, @pRefType)
   IF hr <> S_OK OR pRefType = NULL THEN RETURN ""
   hr = pTypeInfo->GetRefTypeInfo(pRefType, @pImplTypeInfo)
   IF hr <> S_OK OR pImplTypeInfo = NULL THEN RETURN ""
   pImplTypeInfo->GetDocumentation(-1, @bstrName, NULL, NULL, NULL)
   pImplTypeInfo->Release
   RETURN bstrName

END FUNCTION
' ========================================================================================

' ========================================================================================
' Retrieves the inherited interface
' ========================================================================================
FUNCTION TLB_GetInheritedInterface (BYVAL pTypeInfo AS Afx_ITypeInfo PTR, BYVAL idx AS LONG = 0) AS CBSTR

   DIM hr            AS HRESULT             ' // HRESULT
   DIM pRefType      AS HREFTYPE            ' // Address to a referenced type description
   DIM pImplTypeInfo AS Afx_ITypeInfo PTR    ' // Implied interface type info
   DIM pTypeAttr     AS TYPEATTR PTR       ' // Address of a pointer to the TYPEATTR structure

   hr = pTypeInfo->GetRefTypeOfImplType(idx, @pRefType)
   IF hr <> S_OK OR pRefType = NULL THEN RETURN ""
   hr = pTypeInfo->GetRefTypeInfo (pRefType, @pImplTypeInfo)
   IF hr <> S_OK OR pImplTypeInfo = NULL THEN RETURN ""
   hr = pImplTypeInfo->GetTypeAttr(@pTypeAttr)
   DIM cbsInterfaceName AS CBSTR
   IF hr = S_OK AND pTypeAttr <> NULL THEN
      IF @pTypeAttr->cImplTypes = 1 THEN
         cbsInterfaceName = TLB_GetImplementedInterface(pImplTypeInfo, 0)
         pImplTypeInfo->ReleaseTypeAttr(pTypeAttr)
      END IF
   END IF
   pImplTypeInfo->Release
   RETURN cbsInterfaceName

END FUNCTION
' ========================================================================================

' ========================================================================================
' Retrieves the base class
' ========================================================================================
FUNCTION TLB_GetBaseClass (BYVAL pTypeLib AS Afx_ITypeLib PTR, BYREF cbstrItemName AS CBSTR) AS CBSTR

   DIM i                       AS LONG                ' // Loop counter
   DIM hr                      AS HRESULT             ' // HRESULT
   DIM TypeInfoCount           AS LONG                ' // Number of TypeInfos
   DIM pTypeInfo               AS Afx_ITypeInfo PTR   ' // TypeInfo interface
   DIM pTypeAttr               AS TYPEATTR PTR        ' // Address of a pointer to the TYPEATTR structure
   DIM pTKind                  AS TYPEKIND            ' // TYPEKIND
   DIM cbstrName               AS CBSTR               ' // Member's name (unicode)
   DIM cbstrDocString          AS CBSTR               ' // Documentation string (unicode)
   DIM pdwHelpContext          AS DWORD               ' // Help context
   DIM cbstrHelpFile           AS CBSTR               ' // Help file (unicode)
   DIM cbstrInterfaceName      AS CBSTR               ' // Interface name
   DIM pRefType                AS DWORD               ' // Address to a referenced type description
   DIM pRefTypeInfo            AS Afx_ITypeInfo PTR   ' // Referenced TypeInfo interface
   DIM pRefTypeAttr            AS TYPEATTR PTR        ' // Referenced TYPEATTR structure
   DIM cbstrInheritedInterface AS CBSTR               ' // Inherited interface

   TypeInfoCount = pTypeLib->GetTypeInfoCount
   IF TypeInfoCount = 0 THEN RETURN ""

   FOR i = 0 TO TypeInfoCount - 1
      ' // Get the info type
      hr = pTypeLib->GetTypeInfoType(i, @pTKind)
      IF hr <> S_OK THEN EXIT FOR
      ' // Get the type info
      hr = pTypeLib->GetTypeInfo(i, @pTypeInfo)
      IF hr <> S_OK THEN EXIT FOR
      ' // Get the type attribute
      hr = pTypeInfo->GetTypeAttr(@pTypeAttr)
      IF hr <> S_OK OR pTypeAttr = NULL THEN EXIT FOR
      ' // If it is an interface...
      IF pTKind = TKIND_INTERFACE OR pTKind = TKIND_DISPATCH THEN
         ' // Get the name of the interface
         hr = pTypeLib->GetDocumentation(i, @cbstrName, @cbstrDocString, @pdwHelpContext, @cbstrHelpFile)
         ' // If it is the one we are looking for...
         IF cbstrName = cbstrItemName THEN
            ' // If it inherits from another interface, recursively search the methods
            IF (pTypeAttr->wTypeFlags AND TYPEFLAG_FDUAL) = TYPEFLAG_FDUAL THEN
               cbstrInheritedInterface = TLB_GetInheritedInterface(pTypeInfo, -1)
            ELSE
               cbstrInheritedInterface = TLB_GetImplementedInterface(pTypeInfo)
            END IF
            ' // Check also that the interface doesn't inherit from itself!
            IF UCASE(cbstrInheritedInterface) <> "IUNKNOWN" AND UCASE(cbstrInheritedInterface) <> "IDISPATCH" AND UCASE(cbstrInheritedInterface) <> UCASE(cbstrName) THEN
               cbstrInheritedInterface = TLB_GetBaseClass(pTypeLib, cbstrInheritedInterface)
            END IF
         END IF
      END IF
      pTypeInfo->ReleaseTypeAttr(pTypeAttr)
      pTypeAttr = NULL
      pTypeInfo->Release
      pTypeInfo = NULL
   NEXT

   IF pTypeAttr THEN pTypeInfo->ReleaseTypeAttr(pTypeAttr)
   IF pTypeInfo THEN pTypeInfo->Release

   RETURN cbstrInheritedInterface

END FUNCTION
' ========================================================================================


[José Roca]

That's all Folks!