Accessing Type Libraries from VB
By William R. Epp, December 01, 1999
December 1999/Accessing Type Libraries from VB/Listing 1
Attribute VB_Name = "basTypeInfo"
Option Explicit
Public Sub invoke(nSelected As Node, obj As Object)
Dim iDash As Integer
Dim iParmIndx As Integer
Dim iNbrParms As Integer
Dim sMethod As String
Dim sParmValue As String
Dim vParm As Variant
Dim vaParms() As Variant
Dim nChild As Node
Dim ii As InterfaceInfo
Dim mi As MemberInfo
Dim tli As TLIApplication
'/* error trapping */
On Error GoTo invoke_error
Set tli = New TLIApplication
'/* methods/properties always delimited with a dash */
sMethod = nSelected.Text
iDash = InStr(sMethod, "-")
If iDash > 0 Then
sMethod = Trim$(Left$(sMethod, iDash - 1))
Set ii = tli.InterfaceInfoFromObject(obj)
'/* get member by id */
'/* (tag set in loadTreeViewWithClassInfo) */
Set mi = ii.Members.Item(nSelected.Tag)
Select Case mi.InvokeKind
Case INVOKE_FUNC
iNbrParms = mi.Parameters.Count
If iNbrParms > 0 Then
ReDim vaParms(iNbrParms - 1)
'/* there is one child item in treeview */
'/* for each invoke method parameter */
Set nChild = nSelected.Child
For iParmIndx = 1 To nSelected.Children
sParmValue = InputBox( _
"Enter Parameter Value " & _
nChild.Text)
'/* blank - assume optional and remove */
If Trim$(sParmValue) = "" Then
ReDim Preserve vaParms(iNbrParms - 1)
Else
'/* set parameter type */
'/* (tag set in loadTreeViewWithClassInfo) */
vaParms(iNbrParms - 1) = _
setType(sParmValue, nChild.Tag)
End If
'/* in reverse order! */
iNbrParms = iNbrParms - 1
Set nChild = nChild.Next
Next iParmIndx
vParm = tli.InvokeHookArray(obj, sMethod, _
INVOKE_FUNC, vaParms())
Else
'/* no parameters */
vParm = tli.InvokeHook(obj, sMethod, _
INVOKE_FUNC)
End If
MsgBox "Return = " & vParm
Case INVOKE_PROPERTYPUT
sParmValue = InputBox( _
"Enter Value for Property ", _
"Property Put")
If sParmValue <> "" Then
vParm = setType(sParmValue, mi.ReturnType)
Call tli.InvokeHook(obj, sMethod, _
INVOKE_PROPERTYPUT, vParm)
End If
Case INVOKE_PROPERTYGET
vParm = tli.InvokeHook(obj, sMethod, _
INVOKE_PROPERTYGET)
MsgBox "Property Value = " & vParm
End Select
End If
invoke_exit:
Set mi = Nothing
Set ii = Nothing
Set tli = Nothing
Exit Sub
invoke_error:
MsgBox Err.Number & " : " & Err.Description & " (invoke)"
Resume invoke_exit
End Sub
Public Function loadListboxWithClassNames(sFilename As String, _
lstClasses As ListBox) _
As String
Dim iTypeIndx As Integer
Dim sRetInfo As String
Dim ti As TypeLibInfo
Dim tli As TLIApplication
'/* error trapping */
On Error GoTo loadListboxWithClassNames_error
Set tli = New TLIApplication
Set ti = New TypeLibInfo
Set ti = tli.TypeLibInfoFromFile(sFilename)
sRetInfo = ti.Guid & " " & ti.MajorVersion & "." & _
ti.MinorVersion
lstClasses.Clear
For iTypeIndx = 1 To ti.TypeInfoCount
'/* only classes - ignore anything else */
If ti.TypeInfos.Item(iTypeIndx).TypeKind = _
TKIND_COCLASS Then
lstClasses.AddItem ti.Name & "." & _
ti.TypeInfos.Item(iTypeIndx).Name
End If
Next iTypeIndx
loadListboxWithClassNames_exit:
Set ti = Nothing
Set tli = Nothing
'/* return */
loadListboxWithClassNames = sRetInfo
Exit Function
loadListboxWithClassNames_error:
MsgBox Err.Number & " : " & Err.Description & _
" (loadListboxWithClassNames)"
Resume loadListboxWithClassNames_exit
End Function
Public Function loadTreeviewWithClassInfo(sCOMName As String, _
tvwClasses As TreeView) _
As String
Dim iMemberIndx As Integer
Dim iNbrMembers As Integer
Dim iParameterIndx As Integer
Dim iTreeviewIndx As Integer
Dim iSaveIndx As Integer
Dim iNbrParms As Integer
Dim iMemberID As Integer
Dim sRetInfo As String
Dim obj As Object
Dim n As Node
Dim ii As InterfaceInfo
Dim mi As MemberInfo
Dim ti As TypeLibInfo
Dim tli As TLIApplication
'/* error trapping */
On Error GoTo loadTreeviewWithClassInfo_error
Set obj = CreateObject(sCOMName)
Set tli = New TLIApplication
Set ti = New TypeLibInfo
Set ii = tli.InterfaceInfoFromObject(obj)
iNbrMembers = ii.Members.Count
Set ti = ii.Parent
sRetInfo = ti.Guid & " " & ti.MajorVersion & "." & _
ti.MinorVersion
tvwClasses.Nodes.Clear
tvwClasses.Nodes.Add , , , Mid$(ii.Name, 2)
'/* treeview index, assign to each node sequentially */
iTreeviewIndx = 1
'/* type lib id for method, ie. function or property get/put */
iMemberID = 0
For iMemberIndx = 1 To iNbrMembers
Set mi = ii.Members.Item(iMemberIndx)
iMemberID = iMemberID + 1
If Not ignoreName(mi.Name) Then
'/* method name, method type and return type */
tvwClasses.Nodes.Add 1, tvwChild, , mi.Name & " - " & _
getInvokeKindsName(mi.InvokeKind) & _
" (" & getVTTypeName(mi.ReturnType) & ")"
iTreeviewIndx = iTreeviewIndx + 1
'/* save member id - see InvokeHook logic */
tvwClasses.Nodes.Item(iTreeviewIndx).Tag = iMemberID
iNbrParms = mi.Parameters.Count
iSaveIndx = iTreeviewIndx
For iParameterIndx = 1 To iNbrParms
'/* parameter name and type as child node of method */
tvwClasses.Nodes.Add iSaveIndx, tvwChild, , _
mi.Parameters.Item(iParameterIndx).Name & _
" (" & getVTTypeName(mi.Parameters.Item _
(iParameterIndx).VarTypeInfo) & ")"
iTreeviewIndx = iTreeviewIndx + 1
'/* save parameter type - see InvokeHook logic */
tvwClasses.Nodes.Item(iTreeviewIndx).Tag = _
mi.Parameters(iParameterIndx).VarTypeInfo
Next iParameterIndx
End If
Next iMemberIndx
tvwClasses.Nodes(1).Expanded = True
loadTreeviewWithClassInfo_exit:
Set mi = Nothing
Set ii = Nothing
Set ti = Nothing
Set tli = Nothing
Set obj = Nothing
'/* return */
loadTreeviewWithClassInfo = sRetInfo
Exit Function
loadTreeviewWithClassInfo_error:
MsgBox Err.Number & " : " & Err.Description & _
" (loadTreeviewWithClassInfo)"
Resume loadTreeviewWithClassInfo_exit
End Function
