VB枚举控件属性

'   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   

End   Sub 

引用通告地址: http://blog.tomatoit.net/trackback.asp?tbID=171