由于工作的需要,我希望将长长的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的一些缺陷




























































相关测试类:




测试模块:






























































这只是一个简易的框架,自己用来玩玩还行,主要的好处就是通过字符串可以快速的生成对象,或者获取属性的值,而且支持多层次的属性字符串,也支持类似于Item格式的对象集合。
参考文章:
1: vb6框架设计-对象导航
2: CallByName的一些缺陷