Работа с ITypeLib, ITypeInfo в VB6

Option Explicit
 
' Ðàáîòà ñ ITypeLib, ITypeInfo VB6
' © Êðèâîóñ Àíàòîëèé Àíàòîëüåâè÷ (The trick), 2014
 
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As Long
    lpstrCustomFilter As Long
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As Long
    nMaxFile As Long
    lpstrFileTitle As Long
    nMaxFileTitle As Long
    lpstrInitialDir As Long
    lpstrTitle As Long
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub VariantCopy Lib "oleaut32.dll" (pvargDest As Any, pvargSrc As Any)
 
Private Const ControlSpacing = 5
 
Dim IID_IUnknown As UUID
Dim IID_IDispatch As UUID
Dim KeyIndex As Long
Dim lib As ITypeLib
 
Private Sub Form_Load()
    
    LoadLibrary "msvbvm60.dll"
    
    CLSIDFromString "{00000000-0000-0000-C000-000000000046}", IID_IUnknown
    CLSIDFromString "{00020400-0000-0000-C000-000000000046}", IID_IDispatch
 
End Sub
 
Private Function LoadLibrary(Path As String) As Boolean
    Dim typCnt      As Long, Idx            As Long, ptr        As Long, libHelp      As String, libDesc       As String, _
        libName     As String, libAttr      As TLIBATTR, inf    As ITypeInfo, typName As String, tmp           As String, _
        locLib      As ITypeLib
        
    On Error GoTo ErrorLoading
    ' Ïîëó÷àåì óêàçàòåëü íà èíòåðôåéñ ITypeLib
    Set locLib = LoadTypeLibEx(Path, REGKIND_NONE)
    ' Ïîëó÷àåì äîêóìåíòàöèþ äëÿ áèáëèîòåêè
    locLib.GetDocumentation -1, libName, libDesc, 0, libHelp
    ' Ïîëó÷àåì óêàçàòåëü íà àòðèáóòû áèáëèîòåêè
    ptr = locLib.GetLibAttr
    ' Êîïèðóåì äàííûå
    CopyMemory libAttr, ByVal ptr, Len(libAttr)
    ' Îñâîáîæäàåì ïàìÿòü
    locLib.ReleaseTLibAttr ptr
    ' Ïîëó÷àåì êîëè÷åñòâî òèïîâ â áèáëèîòåêå
    typCnt = locLib.GetTypeInfoCount()
    lvwClasses.ListItems.Clear
    ' Ïîëó÷åíèè èíôîðìàöèè î êàæäîì òèïå
    For Idx = 0 To typCnt - 1
        Set inf = locLib.GetTypeInfo(Idx)
        inf.GetDocumentation -1, typName, vbNullString, 0, vbNullString
        lvwClasses.ListItems.Add , , typName, , locLib.GetTypeInfoType(Idx) + 1
    Next
    ' Óñòàíîâêà ñòàòóñà
    stbStatus.Panels("path").Text = Path
    stbStatus.Panels("name").Text = libName
    stbStatus.Panels("desc").Text = libDesc
    
    Set lib = locLib
    
    LoadLibrary = True
    Exit Function
ErrorLoading:
    
    MsgBox "'" & Err.Number & "' " & Err.Description, vbCritical
End Function
 
Private Sub Form_Resize()
    If Me.ScaleWidth < ControlSpacing * 3 + 230 Or Me.ScaleHeight < ControlSpacing * 2 + stbStatus.Height Then Exit Sub
    lvwClasses.Move ControlSpacing, ControlSpacing, 230, Me.ScaleHeight - ControlSpacing * 2 - stbStatus.Height
    tvwMembers.Move lvwClasses.Left + lvwClasses.Width + ControlSpacing, ControlSpacing, _
                    Me.ScaleWidth - lvwClasses.Width - ControlSpacing * 3, lvwClasses.Height
End Sub
 
Private Sub lvwClasses_ItemClick(ByVal Item As ComctlLib.ListItem)
    KeyIndex = 0
    tvwMembers.Nodes.Clear
    GetMembersInfo lib.GetTypeInfo(Item.Index - 1), vbNullString
End Sub
 
Private Function GetMembersInfo(inf As ITypeInfo, KeyNode As String) As Boolean
    Dim hType       As Long, Idx        As Long, ptr        As Long, typAttr        As TYPEATTR, fncInfo        As FUNCDESC, _
        itmName     As String, varInfo  As VARDESC, icn     As Long, itmHelp        As String, IName            As String, _
        locKey      As String, arrDesc  As ARRAYDESC, sa()  As SAFEARRAYBOUND, cnst As Variant, tmp             As Long
    ' Ïîëó÷àåì àòðèáóòû
    ptr = inf.GetTypeAttr()
    CopyMemory typAttr, ByVal ptr, Len(typAttr)
    inf.ReleaseTypeAttr ptr
    ' Åñëè ýòî êîêëàññ, èíòåðôåéñ
    If typAttr.TYPEKIND = TKIND_INTERFACE Or _
       typAttr.TYPEKIND = TKIND_COCLASS Or _
       typAttr.TYPEKIND = TKIND_DISPATCH Then
       ' Èíôîðìàöèÿ î ðåàëèçóåìûõ èíòåðôåéñàõ
        If typAttr.TYPEKIND <> TKIND_COCLASS Then
            ' Åñëè ýòî íå êîêëàññ òî äîáàâëÿåì â ñïèñîê èíòåðôåéñ
            ' Ïîëó÷àåì èìÿ èíòåðôåéñà
            IName = GetInterfaceName(typAttr.iid)
            ' Ñîçäàåì ðîäèòåëüñêèé êëþ÷ äëÿ ïðîèçâîäíûõ èíòåðôåéñîâ
            locKey = "m_" & CStr(KeyIndex)
            ' Äîáàâëÿåì â äåðåâî
            If Len(KeyNode) Then
                tvwMembers.Nodes.Add(KeyNode, tvwChild, locKey, IName, 4).Expanded = True
            Else
                tvwMembers.Nodes.Add(, , locKey, IName, 4).Expanded = True
            End If
            ' Ñëåäóþùèé ýëåìåíò äåðåâà
            KeyIndex = KeyIndex + 1
        End If
        ' Ïðîõîäèì ïî ñïèñêó ðåàëèçóåìûõ èíòåðôåéñîâ
        On Error GoTo ErrDll
        For Idx = 0 To typAttr.cImplTypes - 1
            hType = inf.GetRefTypeOfImplType(Idx)
            ' Äîáàâëÿåì èõ â äî÷åðíèé óçåë
            GetMembersInfo inf.GetRefTypeInfo(hType), locKey
ErrDll:
        Next
        ' Ïîëó÷åíèå èíôîðìàöèè î ìåòîäàõ
        For Idx = 0 To typAttr.cFuncs - 1
            ' Ïîëó÷àåì îïèñàíèå ìåòîäà
            ptr = inf.GetFuncDesc(Idx)
            CopyMemory fncInfo, ByVal ptr, Len(fncInfo)
            inf.ReleaseFuncDesc ptr
            ' Ïîëó÷àåì èìÿ è îïèñàíèå ìåòîäà
            inf.GetDocumentation fncInfo.memid, itmName, itmHelp, 0, vbNullString
            ' Ïîëó÷àåì òèï ìåòîäà è óñòàíàâëèâàåì ñîîòâåòñòâóþùóþ èêîíêó
            Select Case fncInfo.invkind
            Case INVOKEKIND.INVOKE_FUNC: icn = 2
            Case INVOKEKIND.INVOKE_PROPERTYGET: icn = 5
            Case Else: icn = 6
            End Select
            ' Äîáàâëÿåì â ñïèñîê
            tvwMembers.Nodes.Add(locKey, tvwChild, "m_" & CStr(KeyIndex), itmName, icn).Tag = itmHelp
            ' Ñëåäóþùèé ýëåìåíò äåðåâà
            KeyIndex = KeyIndex + 1
        Next
    Else
        ' Åñëè ïñåâäîíèì
        If typAttr.TYPEKIND = TKIND_ALIAS Then
            ' Ïîëó÷àåì òèï ïåðåìåííîé
            Do
                Select Case typAttr.tdescAlias.vt
                Case VARENUM.VT_USERDEFINED
                    ' Åñëè ïñåâäîíèì UDT
                    GetMembersInfo inf.GetRefTypeInfo(typAttr.tdescAlias.pTypeDesc), KeyNode
                    Exit Do
                Case VARENUM.VT_PTR
                    ' Åñëè ýòî ññûëêà, òî ïîëó÷àåì ñîäåðæèìîå
                    CopyMemory typAttr.tdescAlias, ByVal typAttr.tdescAlias.pTypeDesc, Len(typAttr.tdescAlias)
                Case VARENUM.VT_CARRAY
                    ' Ýòî ìàññèâ
                    CopyMemory arrDesc, ByVal typAttr.tdescAlias.pTypeDesc, Len(arrDesc)
                    typAttr.tdescAlias = arrDesc.tdescElem
                Case Else
                    icn = 10
                    ' Ýòî ñòàíäàðòíûé òèï
                    itmName = Switch(typAttr.tdescAlias.vt = VARENUM.VT_BOOL, "Boolean", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_BSTR, "String", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_CARRAY, "CArray", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_CY, "Currency", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_DATE, "Date", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_DECIMAL, "Decimal", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_DISPATCH, "IDispatch", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_ERROR, "SCODE", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_I1, "Char", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_I2, "Integer", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_I4, "Long", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_I8, "Int64", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_INT, "Int", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_LPSTR, "lpStr", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_LPWSTR, "lpwStr", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_R4, "Single", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_R8, "Double", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_SAFEARRAY, "Array", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UI1, "Byte", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UI2, "UShort", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UI4, "ULong", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UI8, "UInt64", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UINT, "UInt", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_UNKNOWN, "IUnknown", _
                                     typAttr.tdescAlias.vt = VARENUM.VT_VARIANT, "Variant")
                    ' Äîáàâëÿåì â ñïèñîê
                    If Len(KeyNode) Then
                        tvwMembers.Nodes.Add KeyNode, tvwChild, locKey, itmName, icn
                    Else
                        tvwMembers.Nodes.Add , , locKey, itmName, icn
                    End If
                    Exit Do
                End Select
            Loop
        Else
        ' Åñëè íå ïñåâäîíèì
            'Ïðîõîäèì ïî ñïèñêó ýëåìåíòîâ ïåðåìåííûõ, êîíñòàíò
            For Idx = 0 To typAttr.cVars - 1
                ' Ïîëó÷àåì îïèñàíèå
                ptr = inf.GetVarDesc(Idx)
                CopyMemory varInfo, ByVal ptr, Len(varInfo)
                ' Ïîëó÷àåì èìÿ, îïèñàíèå
                inf.GetDocumentation varInfo.memid, itmName, itmHelp, 0, vbNullString
                ' Ïîëó÷àåì òèï ýëåìåíòà è óñòàíàâëèâàåì èêîíêó
                Select Case varInfo.VARKIND
                Case VARKIND.VAR_CONST
                    icn = 1
                    VariantCopy cnst, ByVal varInfo.oInst_varValue
                    itmName = itmName & " = " & cnst & " (&H" & Hex(cnst) & ")"
                Case VARKIND.VAR_PERINSTANCE
                    If typAttr.TYPEKIND = TKIND_ENUM Then
                        icn = 1
                        VariantCopy cnst, ByVal varInfo.oInst_varValue
                        itmName = itmName & " = " & cnst & " (&H" & Hex(cnst) & ")"
                    Else
                        icn = 10
                    End If
                Case Else: icn = 0
                End Select
                ' Äîáàâëÿåì â ñïèñîê
                If Len(KeyNode) Then
                    tvwMembers.Nodes.Add(KeyNode, tvwChild, locKey, itmName, icn).Tag = itmHelp
                Else
                    tvwMembers.Nodes.Add(, , locKey, itmName, icn).Tag = itmHelp
                End If
                ' Ñëåäóþùèé ýëåìåíò äåðåâà
                KeyIndex = KeyIndex + 1
                inf.ReleaseVarDesc ptr
            Next
            ' Ïðîõîä ïî ñïèñêó ôóíêöèé
            For Idx = 0 To typAttr.cFuncs - 1
                ' Ïîëó÷àåì îïèñàíèå
                ptr = inf.GetFuncDesc(Idx)
                CopyMemory fncInfo, ByVal ptr, Len(fncInfo)
                inf.ReleaseFuncDesc ptr
                ' Ïîëó÷àåì èìÿ, îïèñàíèå
                inf.GetDocumentation fncInfo.memid, itmName, itmHelp, 0, vbNullString
                ' Äîáàâëÿåì â ñïèñîê
                If Len(KeyNode) Then
                    tvwMembers.Nodes.Add(KeyNode, tvwChild, locKey, itmName, 2).Tag = itmHelp
                Else
                    tvwMembers.Nodes.Add(, , locKey, itmName, 2).Tag = itmHelp
                End If
                ' Ñëåäóþùèé ýëåìåíò äåðåâà
                KeyIndex = KeyIndex + 1
            Next
        End If
    End If
    
End Function
' Ïîëó÷èòü èìÿ èíòåðôåéñà
Private Function GetInterfaceName(guid As UUID) As String
    Dim inf     As ITypeInfo, i     As Long
    
    On Error GoTo ErrUnkInterface
    
    Select Case True
    Case IsEqualGUID(guid, IID_IUnknown)
        GetInterfaceName = "IUnknown"
    Case IsEqualGUID(guid, IID_IDispatch)
        GetInterfaceName = "IDispatch"
    Case Else
        Set inf = lib.GetTypeInfoOfIID(guid)
        inf.GetDocumentation -1, GetInterfaceName, vbNullString, 0, vbNullString
    End Select
    
    Exit Function
ErrUnkInterface:
    GetInterfaceName = "ERROR"
    'S1 = Space(255)
    'i = StringFromGUID2(guid, StrPtr(S1), Len(S1))
    'S1 = Left(S1, i)
End Function
 
Private Sub mnuOpen_Click()
    Dim ofn     As OPENFILENAME, Out    As String, i        As Long
    
    ofn.nMaxFile = 260
    Out = String(260, vbNullChar)
 
    ofn.hwndOwner = hWnd
    ofn.lpstrTitle = StrPtr("Îòêðûòü ôàéë")
    ofn.lpstrFile = StrPtr(Out)
    ofn.lStructSize = Len(ofn)
    ofn.lpstrFilter = StrPtr("Ïîääåðæèâàåìûå ôàéëû" & vbNullChar & "*.dll;*.ocx;*.tlb" & vbNullChar)
    
    If GetOpenFileName(ofn) Then
        i = InStr(1, Out, vbNullChar, vbBinaryCompare)
        If i Then Out = Left$(Out, i - 1)
        LoadLibrary Out
    End If
End Sub
 
Private Sub mnuQuit_Click()
    Unload Me
End Sub
 
Private Sub tvwMembers_NodeClick(ByVal Node As ComctlLib.Node)
    stbStatus.Panels("help").Text = Node.Tag
End Sub