' BAS Code
Option Explicit
Public Function CreateTLIobject() As Object
On Error Resume Next
'───错误保护结构───'
Set CreateTLIobject = CreateObject("TLI.TLIapplication")
'───错误保护结构───'
On Error GoTo 0
End Function
Public Function EnumComTypeInfo(ByVal ComFilePath As String, ByVal OutOBJ As Control)
Dim TLinfoApp As Object
Dim TLinfo As Object 'TypeLibInfo
Dim tlCoClass As Object 'CoClassInfo
Dim tlTypeInfo As Object 'TypeInfo
Dim tlCons As Object 'ConstantInfo
Dim tlInterface As Object 'InterfaceInfo
Dim tlName As String
Dim ClassName As String
Dim CoClass As String
Dim IntertfaceName As String
Dim LV As TreeView
Dim LVitem As ListItem
Set TLinfoApp = CreateTLIobject
If TLinfoApp Is Nothing Then
MsgBox "无法调用系统对象"
Exit Function
End If
' 定义输出对象
If TypeOf OutOBJ Is TreeView Then
Set LV = OutOBJ
End If
Set TLinfo = TLinfoApp.TypeLibInfoFromFile(ComFilePath)
tlName = TLinfo.Name
' 添加Com名称
If Not LV Is Nothing Then LV.Nodes.Add , , tlName, tlName
' 枚举CoClass
If TLinfo.CoClasses.Count > 0 Then
' 列表添加 CoClass Nodes
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "CoClass", "CoClass"
LV.Nodes.Item("CoClass").Sorted = True ' 子项排序
End If
For Each tlCoClass In TLinfo.CoClasses
ClassName = tlCoClass.Name ' 获得类的名称
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "CoClass", 4, , ClassName
Next
End If
' 枚举TypeInfos
If TLinfo.TypeInfos.Count > 0 Then
' 列表添加 TypeInfos Nodes
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "TypeInfos", "TypeInfos"
LV.Nodes.Item("TypeInfos").Sorted = True
End If
For Each tlTypeInfo In TLinfo.TypeInfos
ClassName = tlTypeInfo.Name ' 获得类的名称
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "TypeInfos", 4, , ClassName
Next
End If
' 列表添加 Constants Nodes
If TLinfo.Constants.Count > 0 Then
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "Constants", "Constants"
LV.Nodes.Item("Constants").Sorted = True
End If
For Each tlCons In TLinfo.Constants
CoClass = tlCons.Name
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "Constants", 4, , CoClass
Next
End If
' 列表添加 Interfaces Nodes
If TLinfo.Interfaces.Count > 0 Then
' 输出信息
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "Interfaces", "Interfaces"
LV.Nodes.Item("Interfaces").Sorted = True
End If
For Each tlInterface In TLinfo.Interfaces
IntertfaceName = tlInterface.Name
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "Interfaces", 4, , IntertfaceName
Next
End If
' 列表排序
If Not LV Is Nothing Then
LV.Nodes.Item(tlName).Sorted = True
LV.Nodes.Item(tlName).Expanded = True
End If
Set TLinfo = Nothing
End Function
Function GetTypeInfo(ByVal TLfilePath As String, ByVal TypeInfoName As String, ByVal OutOBJ As Control) As String
Dim TLinfoApp As TLI.TLIApplication
Dim TypeInfo As TypeLibInfo
Dim Mem As Object
Dim MemberInfo As MemberInfo
Dim LV As ListView
Dim LVitem As ListItem
Dim memOBJ As Object
Set TLinfoApp = CreateTLIobject
If TLinfoApp Is Nothing Then
MsgBox "无法调用系统对象"
Exit Function
End If
If TypeOf OutOBJ Is ListView Then
Set LV = OutOBJ
LV.ListItems.Clear ' 清空列表
LV.ColumnHeaders.Clear ' 清空标题
LV.ColumnHeaders.Add , , "Name", 2888
LV.ColumnHeaders.Add , , "DescKind", 1888
LV.ColumnHeaders.Add , , "InvokeKind", 1888
End If
Set TypeInfo = TLinfoApp.TypeLibInfoFromFile(TLfilePath)
Set Mem = TypeInfo.TypeInfos.NamedItem(TypeInfoName) ' 这里的Mem用对象适因为Mem可能是TypeInfo,Interfaces等对象
On Error Resume Next
If Mem.Members.Count > 0 Then
If Err Then
Err.Clear
For Each memOBJ In TypeInfo.TypeInfos.NamedItem(TypeInfoName).DefaultInterface.Members
If Not LV Is Nothing Then
Set LVitem = LV.ListItems.Add(, , memOBJ.Name)
LVitem.SubItems(1) = GetDescKindStr(memOBJ.DescKind)
LVitem.SubItems(2) = GetInvokeKindStr(memOBJ.InvokeKind)
End If
Next
Else
For Each memOBJ In Mem.Members
If Not LV Is Nothing Then
Set LVitem = LV.ListItems.Add(, , memOBJ.Name)
LVitem.SubItems(1) = GetDescKindStr(memOBJ.DescKind)
LVitem.SubItems(2) = GetInvokeKindStr(memOBJ.InvokeKind)
End If
Next
End If
End If
On Error GoTo 0
Set TLinfoApp = Nothing
End Function
Function GetDescKindStr(ByVal DescKind As DescKinds) As String
Select Case DescKind
Case DESCKIND_FUNCDESC: GetDescKindStr = "DESCKIND_FUNCDESC"
Case DESCKIND_NONE: GetDescKindStr = "DESCKIND_NONE"
Case DESCKIND_VARDESC: GetDescKindStr = "DESCKIND_VARDESC"
End Select
End Function
Function GetInvokeKindStr(ByVal InvokeKind As InvokeKinds) As String
Select Case InvokeKind
Case INVOKE_CONST: GetInvokeKindStr = ""
Case INVOKE_EVENTFUNC: GetInvokeKindStr = "INVOKE_EVENTFUNC"
Case INVOKE_FUNC: GetInvokeKindStr = "INVOKE_FUNC"
Case INVOKE_PROPERTYGET: GetInvokeKindStr = "INVOKE_PROPERTYGET"
Case INVOKE_PROPERTYPUT: GetInvokeKindStr = "INVOKE_PROPERTYPUT"
Case INVOKE_PROPERTYPUTREF: GetInvokeKindStr = "INVOKE_PROPERTYPUTREF"
Case INVOKE_UNKNOWN: GetInvokeKindStr = "INVOKE_UNKNOWN"
End Select
End Function
'-----------------------------------------------------------------------------------------------
' Form Code
Dim TLfilePath As String ' 类型库文件路径
Private Sub Form_Load()
Me.CommonDialog1.ShowOpen ' 调用打开文件对话框
If Me.CommonDialog1.FileName <> "" Then
TLfilePath = Me.CommonDialog1.FileName ' 记录类型库路径
EnumComTypeInfo Me.CommonDialog1.FileName, Me.TreeView1 ' 获得类信息
End If
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Me.ListView1.SortKey = ColumnHeader.Index - 1
Me.ListView1.Sorted = True
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
If Not Node.Parent Is Nothing Then
Select Case Node.Parent.Text
Case "CoClass":
Case "TypeInfos": GetTypeInfo TLfilePath, Node.Text, Me.ListView1
Case "Constants"
Case "Interfaces"
End Select
End If
Option Explicit
Public Function CreateTLIobject() As Object
On Error Resume Next
'───错误保护结构───'
Set CreateTLIobject = CreateObject("TLI.TLIapplication")
'───错误保护结构───'
On Error GoTo 0
End Function
Public Function EnumComTypeInfo(ByVal ComFilePath As String, ByVal OutOBJ As Control)
Dim TLinfoApp As Object
Dim TLinfo As Object 'TypeLibInfo
Dim tlCoClass As Object 'CoClassInfo
Dim tlTypeInfo As Object 'TypeInfo
Dim tlCons As Object 'ConstantInfo
Dim tlInterface As Object 'InterfaceInfo
Dim tlName As String
Dim ClassName As String
Dim CoClass As String
Dim IntertfaceName As String
Dim LV As TreeView
Dim LVitem As ListItem
Set TLinfoApp = CreateTLIobject
If TLinfoApp Is Nothing Then
MsgBox "无法调用系统对象"
Exit Function
End If
' 定义输出对象
If TypeOf OutOBJ Is TreeView Then
Set LV = OutOBJ
End If
Set TLinfo = TLinfoApp.TypeLibInfoFromFile(ComFilePath)
tlName = TLinfo.Name
' 添加Com名称
If Not LV Is Nothing Then LV.Nodes.Add , , tlName, tlName
' 枚举CoClass
If TLinfo.CoClasses.Count > 0 Then
' 列表添加 CoClass Nodes
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "CoClass", "CoClass"
LV.Nodes.Item("CoClass").Sorted = True ' 子项排序
End If
For Each tlCoClass In TLinfo.CoClasses
ClassName = tlCoClass.Name ' 获得类的名称
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "CoClass", 4, , ClassName
Next
End If
' 枚举TypeInfos
If TLinfo.TypeInfos.Count > 0 Then
' 列表添加 TypeInfos Nodes
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "TypeInfos", "TypeInfos"
LV.Nodes.Item("TypeInfos").Sorted = True
End If
For Each tlTypeInfo In TLinfo.TypeInfos
ClassName = tlTypeInfo.Name ' 获得类的名称
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "TypeInfos", 4, , ClassName
Next
End If
' 列表添加 Constants Nodes
If TLinfo.Constants.Count > 0 Then
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "Constants", "Constants"
LV.Nodes.Item("Constants").Sorted = True
End If
For Each tlCons In TLinfo.Constants
CoClass = tlCons.Name
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "Constants", 4, , CoClass
Next
End If
' 列表添加 Interfaces Nodes
If TLinfo.Interfaces.Count > 0 Then
' 输出信息
If Not LV Is Nothing Then
LV.Nodes.Add tlName, 4, "Interfaces", "Interfaces"
LV.Nodes.Item("Interfaces").Sorted = True
End If
For Each tlInterface In TLinfo.Interfaces
IntertfaceName = tlInterface.Name
' 输出信息
If Not LV Is Nothing Then LV.Nodes.Add "Interfaces", 4, , IntertfaceName
Next
End If
' 列表排序
If Not LV Is Nothing Then
LV.Nodes.Item(tlName).Sorted = True
LV.Nodes.Item(tlName).Expanded = True
End If
Set TLinfo = Nothing
End Function
Function GetTypeInfo(ByVal TLfilePath As String, ByVal TypeInfoName As String, ByVal OutOBJ As Control) As String
Dim TLinfoApp As TLI.TLIApplication
Dim TypeInfo As TypeLibInfo
Dim Mem As Object
Dim MemberInfo As MemberInfo
Dim LV As ListView
Dim LVitem As ListItem
Dim memOBJ As Object
Set TLinfoApp = CreateTLIobject
If TLinfoApp Is Nothing Then
MsgBox "无法调用系统对象"
Exit Function
End If
If TypeOf OutOBJ Is ListView Then
Set LV = OutOBJ
LV.ListItems.Clear ' 清空列表
LV.ColumnHeaders.Clear ' 清空标题
LV.ColumnHeaders.Add , , "Name", 2888
LV.ColumnHeaders.Add , , "DescKind", 1888
LV.ColumnHeaders.Add , , "InvokeKind", 1888
End If
Set TypeInfo = TLinfoApp.TypeLibInfoFromFile(TLfilePath)
Set Mem = TypeInfo.TypeInfos.NamedItem(TypeInfoName) ' 这里的Mem用对象适因为Mem可能是TypeInfo,Interfaces等对象
On Error Resume Next
If Mem.Members.Count > 0 Then
If Err Then
Err.Clear
For Each memOBJ In TypeInfo.TypeInfos.NamedItem(TypeInfoName).DefaultInterface.Members
If Not LV Is Nothing Then
Set LVitem = LV.ListItems.Add(, , memOBJ.Name)
LVitem.SubItems(1) = GetDescKindStr(memOBJ.DescKind)
LVitem.SubItems(2) = GetInvokeKindStr(memOBJ.InvokeKind)
End If
Next
Else
For Each memOBJ In Mem.Members
If Not LV Is Nothing Then
Set LVitem = LV.ListItems.Add(, , memOBJ.Name)
LVitem.SubItems(1) = GetDescKindStr(memOBJ.DescKind)
LVitem.SubItems(2) = GetInvokeKindStr(memOBJ.InvokeKind)
End If
Next
End If
End If
On Error GoTo 0
Set TLinfoApp = Nothing
End Function
Function GetDescKindStr(ByVal DescKind As DescKinds) As String
Select Case DescKind
Case DESCKIND_FUNCDESC: GetDescKindStr = "DESCKIND_FUNCDESC"
Case DESCKIND_NONE: GetDescKindStr = "DESCKIND_NONE"
Case DESCKIND_VARDESC: GetDescKindStr = "DESCKIND_VARDESC"
End Select
End Function
Function GetInvokeKindStr(ByVal InvokeKind As InvokeKinds) As String
Select Case InvokeKind
Case INVOKE_CONST: GetInvokeKindStr = ""
Case INVOKE_EVENTFUNC: GetInvokeKindStr = "INVOKE_EVENTFUNC"
Case INVOKE_FUNC: GetInvokeKindStr = "INVOKE_FUNC"
Case INVOKE_PROPERTYGET: GetInvokeKindStr = "INVOKE_PROPERTYGET"
Case INVOKE_PROPERTYPUT: GetInvokeKindStr = "INVOKE_PROPERTYPUT"
Case INVOKE_PROPERTYPUTREF: GetInvokeKindStr = "INVOKE_PROPERTYPUTREF"
Case INVOKE_UNKNOWN: GetInvokeKindStr = "INVOKE_UNKNOWN"
End Select
End Function
'-----------------------------------------------------------------------------------------------
' Form Code
Dim TLfilePath As String ' 类型库文件路径
Private Sub Form_Load()
Me.CommonDialog1.ShowOpen ' 调用打开文件对话框
If Me.CommonDialog1.FileName <> "" Then
TLfilePath = Me.CommonDialog1.FileName ' 记录类型库路径
EnumComTypeInfo Me.CommonDialog1.FileName, Me.TreeView1 ' 获得类信息
End If
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Me.ListView1.SortKey = ColumnHeader.Index - 1
Me.ListView1.Sorted = True
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
If Not Node.Parent Is Nothing Then
Select Case Node.Parent.Text
Case "CoClass":
Case "TypeInfos": GetTypeInfo TLfilePath, Node.Text, Me.ListView1
Case "Constants"
Case "Interfaces"
End Select
End If
End Sub