CallByName的深入研究

由于工作的需要，我希望将长长的Case取消掉，但是CallbyName在层次和集合对象上的处理十分头疼，为了解决这个问题只能想别的办法了，唯一的办法是重新包装Callbyname，代码如下：

' ClassName :ParaseTier

' 缺陷没有考虑错误处理

Public  Event onError()

' 根据字符串得到具体的属性值
Public   Function  GetAttributeValue( Object   As   Object , ByVal AttributeName  As   String )
    GetAttributeValue  =  VBA.Interaction.CallByName( GetObject ( Object , AttributeName),  Trim (AttributeName), VbGet)
End Function

' 根据字符串得到具体的对象
' AttributeIsObject = 0,表示当AttributeName表示的是属性名称
' AttributeIsObject = 1,表示当AttributeName表示的是对象名称
Public   Function   GetObject (ByVal  Object   As   Object , ByRef AtrributeName  As   String , Optional AttributeIsObject  =   0 )  As   Object
     Dim  parseProcName()  As   String
    parseProcName  =   Split (AtrributeName,  " . " )
     Dim  i  As   Integer
     Set   GetObject   =   Object
     For  i  =   0   To   UBound (parseProcName)  -   1
        If  IsCollectionAttribute(parseProcName(i))  Then
             Set   GetObject   =  GetItemObject( GetObject , parseProcName(i))
        Else
             If   IsObject (VBA.Interaction.CallByName( GetObject , parseProcName(i), VbGet))  Then
                 Set   GetObject   =  VBA.Interaction.CallByName( GetObject , parseProcName(i), VbGet)
             End   If
        End   If
     Next
    
     ' 处理需要单独返回对象的属性
     If  AttributeIsObject  =   1   Then
         If   IsObject (VBA.Interaction.CallByName( GetObject , parseProcName( 0 ), VbGet))  Then
             Set   GetObject   =  VBA.Interaction.CallByName( GetObject , parseProcName( 0 ), VbGet)
         End   If
     End   If
    
    AtrributeName  =  parseProcName( UBound (parseProcName))
     Erase  parseProcName
End Function

' 解析集合类对象
' 用来解释如“Sections(1)”格式的集合对象
' 要求集合对象必须包含Item方法
' 字符串不允许包含类似Item(1)的方法
Public   Function  GetItemObject(ByVal  Object   As   Object , ByVal AttributeName  As   String )  As   Object
     Dim  parseProcName()  As   String
    parseProcName  =   Split (AttributeName,  " ( " )
    AttributeName  =   Trim (parseProcName( 0 ))
     Dim  Index  As   Integer
    Index  =   Trim ( Replace (parseProcName( 1 ),  " ) " ,  "" ))
     Set  GetItemObject  =   GetObject ( Object , AttributeName,  1 )
     Set  GetItemObject  =  GetItemObject.Item(Index)
     Erase  parseProcName
End Function

' 判断当前的对象是否为集合对象
Private   Function  IsCollectionAttribute(ByVal AttributeName  As   String )  As   Boolean
    IsCollectionAttribute  =  ( InStr ( 1 , AttributeName,  " ( " )  >   0 )
End Function

相关测试类：

' ClassName :Student
Public  Name  As   String
Public  Sex  As   String

测试模块：

Public   Sub  Test1()
     Dim  pt  As   New  ParaseTier
     Dim  o  As   Object
     Set  o  =  Word.Application.ActiveDocument
    
     ' Demo 使用字符串获得属性
    Debug.Print pt.GetAttributeValue(o,  " Paragraphs(1).Range.Font.Name " )
    
     ' Demo 使用字符串获得集合对象属性
    Debug.Print pt.GetItemObject(o,  " Paragraphs(1) " ).Range.Font.Name
    
     ' Demo 使用字符串获得对象
    Debug.Print pt. GetObject (o,  " Paragraphs " ,  1 ).Count
    
     Set  o  =   Nothing
     Set  pt  =   Nothing
End Sub


Public   Sub  Test2()
     Dim  pt  As   New  ParaseTier
     Dim  o  As   Object
     Set  o  =  Word.Application.ActiveDocument
     ' Demo 使用字符串获得属性
    Debug.Print pt.GetAttributeValue(o,  " Paragraphs(1).Range.Font.Name " )
     ' Demo 使用字符串获得集合对象属性
    Debug.Print pt.GetItemObject(o,  " Sections(1) " ).Index
     ' Demo 使用字符串获得对象
    Debug.Print pt. GetObject (o,  " Paragraphs " ,  1 ).Count
     Set  o  =   Nothing
     Set  pt  =   Nothing
End Sub

Public   Sub  test3()
     Dim  s  As   New  Student
    s.Name  =   " Duiker"
    s.Sex  =   " 男"
     Dim  ss  As   String
    ss  =   InputBox ( " 请输入需要获得的属性名称 " ,  " Name " )
    
     Select   Case  ss
         Case   " Name"
            Debug.Print s.Name
         Case   " Sex"
            Debug.Print s.Sex
     End   Select
    
     Set  s  =   Nothing
End Sub

Public   Sub  test4()
     Dim  s  As   New  Student
    s.Name  =   " Duiker"
    s.Sex  =   " 男"
     Dim  ss  As   String
    ss  =   InputBox ( " 请输入需要获得的属性名称 " ,  " Name " )
     Dim  pt  As   New  ParaseTier
    Debug.Print pt.GetAttributeValue(s, ss)
     Set  s  =   Nothing
End Sub

这只是一个简易的框架，自己用来玩玩还行，主要的好处就是通过字符串可以快速的生成对象，或者获取属性的值，而且支持多层次的属性字符串，也支持类似于Item格式的对象集合。

参考文章：

1： vb6框架设计-对象导航
2： CallByName的一些缺陷