[VBA函数]：对扩展数据进行操作的函数

efan2000

我编了两个函数，可以像属性操作那样方便的操作扩展数据。

2. 
   
3.   [FONT=courier new]
   
4. '获取扩展数据
   
5. EntObj    包含扩展数据的对象
   
6. Name     扩展数据的注册应用程序名称
   
7. Tag        标签（唯一）
   
8. Value     值
   
9. Public Function GetXDataText(ByVal EntObj As AcadObject, ByVal Name As String, ByVal Tag As String) As String
   
10.     Dim xdType As Variant
    
11.     Dim xdData As Variant
    
12.     Dim i As Integer
    
13.     Dim temp As Variant
    
14.    
    
15.     On Error GoTo ErrTrap
    
16.     If EntObj Is Nothing Then Exit Function
    
17.     If Name = "" Or Tag = "" Then Exit Function
    
18.     GetXDataText = ""
    
19.     EntObj.GetXData Name, xdType, xdData
    
20.     If Not IsEmpty(xdType) Then
    
21.         For i = LBound(xdType) To UBound(xdType)
    
22.             If xdData(i) <> "" Then
    
23.                 temp = Split(xdData(i), "=", , vbTextCompare)
    
24.                 If Not IsEmpty(temp) Then
    
25.                     If StrComp(temp(0), Tag, vbTextCompare) = 0 Then
    
26.                         If UBound(temp) >= 1 Then GetXDataText = temp(1)
    
27.                         Exit For
    
28.                     End If
    
29.                 End If
    
30.                 temp = Empty
    
31.             End If
    
32.         Next
    
33.     End If
    
34.     xdType = Empty
    
35.     xdData = Empty
    
36.     Exit Function
    
37.    
    
38. ErrTrap:
    
39.     Debug.Print "GetXDataText: " & Err.Number & ", " & Err.Description
    
40.     On Error GoTo 0
    
41. End Function
    
42. 
    
43. '设置扩展数据
    
44. Public Sub SetXDataText(ByRef EntObj As AcadObject, ByVal Name As String, ByVal Tag As String, ByVal Text As String)
    
45.     Dim xdType As Variant
    
46.     Dim xdData As Variant
    
47.     Dim i As Integer
    
48.     Dim temp As Variant
    
49.     Dim bExist As Boolean
    
50. 
    
51.     On Error GoTo ErrTrap
    
52.     If EntObj Is Nothing Then Exit Sub
    
53.     If Name = "" Or Tag = "" Then Exit Sub
    
54.     EntObj.GetXData Name, xdType, xdData
    
55.     If Not IsEmpty(xdType) Then
    
56.         For i = LBound(xdType) To UBound(xdType)
    
57.             If xdData(i) <> "" Then
    
58.                 temp = Split(xdData(i), "=", , vbTextCompare)
    
59.                 If Not IsEmpty(temp) Then
    
60.                     If StrComp(temp(0), Tag, vbTextCompare) = 0 Then
    
61.                         bExist = True
    
62.                         xdData(i) = Tag & "=" & Text
    
63.                         EntObj.SetXData xdType, xdData
    
64.                         Exit For
    
65.                     End If
    
66.                 End If
    
67.                 temp = Empty
    
68.             End If
    
69.         Next
    
70.         If bExist = False Then
    
71.             temp = UBound(xdType) + 1
    
72.             ReDim Preserve xdType(0 To temp)
    
73.             ReDim Preserve xdData(0 To temp)
    
74.             xdType(temp) = 1000
    
75.             xdData(temp) = Tag & "=" & Text
    
76.             EntObj.SetXData xdType, xdData
    
77.             temp = Empty
    
78.         End If
    
79.     Else
    
80.         ReDim xdType(0 To 1) As Integer
    
81.         ReDim xdData(0 To 1) As Variant
    
82.         xdType(0) = 1001
    
83.         xdData(0) = Name
    
84.         xdType(1) = 1000
    
85.         xdData(1) = Tag & "=" & Text
    
86.         EntObj.SetXData xdType, xdData
    
87.     End If
    
88.     xdType = Empty
    
89.     xdData = Empty
    
90.     Exit Sub
    
91.    
    
92. ErrTrap:
    
93.     Debug.Print "SetXDataText: " & Err.Number & ", " & Err.Description
    
94.     On Error GoTo 0
    
95. End Sub
    
96.   [/FONT]
    

<br />   [FONT=courier new]<br /> '获取扩展数据<br /> EntObj    包含扩展数据的对象<br /> Name     扩展数据的注册应用程序名称<br /> Tag        标签（唯一）<br /> Value     值<br /> Public Function GetXDataText(ByVal EntObj As AcadObject, ByVal Name As String, ByVal Tag As String) As String<br />     Dim xdType As Variant<br />     Dim xdData As Variant<br />     Dim i As Integer<br />     Dim temp As Variant<br />     <br />     On Error GoTo ErrTrap<br />     If EntObj Is Nothing Then Exit Function<br />     If Name = "" Or Tag = "" Then Exit Function<br />     GetXDataText = ""<br />     EntObj.GetXData Name, xdType, xdData<br />     If Not IsEmpty(xdType) Then<br />         For i = LBound(xdType) To UBound(xdType)<br />             If xdData(i) <> "" Then<br />                 temp = Split(xdData(i), "=", , vbTextCompare)<br />                 If Not IsEmpty(temp) Then<br />                     If StrComp(temp(0), Tag, vbTextCompare) = 0 Then<br />                         If UBound(temp) >= 1 Then GetXDataText = temp(1)<br />                         Exit For<br />                     End If<br />                 End If<br />                 temp = Empty<br />             End If<br />         Next<br />     End If<br />     xdType = Empty<br />     xdData = Empty<br />     Exit Function<br />     <br /> ErrTrap:<br />     Debug.Print "GetXDataText: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> '设置扩展数据<br /> Public Sub SetXDataText(ByRef EntObj As AcadObject, ByVal Name As String, ByVal Tag As String, ByVal Text As String)<br />     Dim xdType As Variant<br />     Dim xdData As Variant<br />     Dim i As Integer<br />     Dim temp As Variant<br />     Dim bExist As Boolean<br /> <br />     On Error GoTo ErrTrap<br />     If EntObj Is Nothing Then Exit Sub<br />     If Name = "" Or Tag = "" Then Exit Sub<br />     EntObj.GetXData Name, xdType, xdData<br />     If Not IsEmpty(xdType) Then<br />         For i = LBound(xdType) To UBound(xdType)<br />             If xdData(i) <> "" Then<br />                 temp = Split(xdData(i), "=", , vbTextCompare)<br />                 If Not IsEmpty(temp) Then<br />                     If StrComp(temp(0), Tag, vbTextCompare) = 0 Then<br />                         bExist = True<br />                         xdData(i) = Tag & "=" & Text<br />                         EntObj.SetXData xdType, xdData<br />                         Exit For<br />                     End If<br />                 End If<br />                 temp = Empty<br />             End If<br />         Next<br />         If bExist = False Then<br />             temp = UBound(xdType) + 1<br />             ReDim Preserve xdType(0 To temp)<br />             ReDim Preserve xdData(0 To temp)<br />             xdType(temp) = 1000<br />             xdData(temp) = Tag & "=" & Text<br />             EntObj.SetXData xdType, xdData<br />             temp = Empty<br />         End If<br />     Else<br />         ReDim xdType(0 To 1) As Integer<br />         ReDim xdData(0 To 1) As Variant<br />         xdType(0) = 1001<br />         xdData(0) = Name<br />         xdType(1) = 1000<br />         xdData(1) = Tag & "=" & Text<br />         EntObj.SetXData xdType, xdData<br />     End If<br />     xdType = Empty<br />     xdData = Empty<br />     Exit Sub<br />     <br /> ErrTrap:<br />     Debug.Print "SetXDataText: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Sub<br />   [/FONT]<br />

jacktomm

我正在发愁
split()
编译错误
子程序或函数未定义

efan2000

忘了说明，Split只有在VBA6.0以上才有的。可以放在VB中，做一个动态链接库，以后直接调用就可以了。或者用R2002，它的VBA版本是6.0的。

efan2000

你可以用VB6.0为R2000版本中所没有的VBA函数做一个库，使用时只要引用就可以了，相当于扩充了CAD中VBA的功能。
附上一些例子。

2. 
   
3.   [FONT=courier new]
   
4. Public Enum VbTriState
   
5.     vbFalse = 0
   
6.     vbTrue = -1
   
7.     vbUseDefault = -2
   
8. End Enum
   
9. 
   
10. Public Enum VbCompareMethod
    
11.     vbBinaryCompare = 0
    
12.     vbDatabaseCompare = 2
    
13.     vbTextCompare = 1
    
14. End Enum
    
15. 
    
16. Public Function VBFilter(ByVal SourceArray As Variant, ByVal Match As String, Optional ByVal Include As Boolean = True, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)
    
17.     VBFilter = ""
    
18.     On Error GoTo ErrTrap
    
19.     VBFilter = Filter(SourceArray, Match, Include, Compare)
    
20.     Exit Function
    
21. 
    
22. ErrTrap:
    
23.     Debug.Print "VBFilter: " & Err.Number & ", " & Err.Description
    
24.     On Error GoTo 0
    
25. End Function
    
26. 
    
27. Public Function VBFormatCurrency(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String
    
28.     VBFormatCurrency = ""
    
29.     On Error GoTo ErrTrap
    
30.     VBFormatCurrency = FormatCurrency(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)
    
31.     Exit Function
    
32. 
    
33. ErrTrap:
    
34.     Debug.Print "VBFormatCurrency: " & Err.Number & ", " & Err.Description
    
35.     On Error GoTo 0
    
36. End Function
    
37. 
    
38. Public Function VBFormatDateTime(ByVal Expression As Variant, Optional ByVal NamedFormat As VbDateTimeFormat = vbGeneralDate) As String
    
39.     VBFormatDateTime = ""
    
40.     On Error GoTo ErrTrap
    
41.     VBFormatDateTime = FormatDateTime(Expression, NamedFormat)
    
42.     Exit Function
    
43. 
    
44. ErrTrap:
    
45.     Debug.Print "VBFormatDateTime: " & Err.Number & ", " & Err.Description
    
46.     On Error GoTo 0
    
47. End Function
    
48. 
    
49. Public Function VBFormatNumber(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String
    
50.     VBFormatNumber = ""
    
51.     On Error GoTo ErrTrap
    
52.     VBFormatNumber = FormatNumber(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)
    
53.     Exit Function
    
54. 
    
55. ErrTrap:
    
56.     Debug.Print "VBFormatNumber: " & Err.Number & ", " & Err.Description
    
57.     On Error GoTo 0
    
58. End Function
    
59. 
    
60. Public Function VBFormatPercent(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String
    
61.     VBFormatPercent = ""
    
62.     On Error GoTo ErrTrap
    
63.     VBFormatPercent = FormatPercent(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)
    
64.     Exit Function
    
65. 
    
66. ErrTrap:
    
67.     Debug.Print "VBFormatPercent: " & Err.Number & ", " & Err.Description
    
68.     On Error GoTo 0
    
69. End Function
    
70. 
    
71. Public Function VBInStrRev(ByVal StringCheck As String, StringMatch As String, Optional ByVal Start As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
    
72.     VBInStrRev = ""
    
73.     On Error GoTo ErrTrap
    
74.     VBInStrRev = InStrRev(StringCheck, StringMatch, Start, Compare)
    
75.     Exit Function
    
76. 
    
77. ErrTrap:
    
78.     Debug.Print "VBInStrRev: " & Err.Number & ", " & Err.Description
    
79.     On Error GoTo 0
    
80. End Function
    
81. 
    
82. Public Function VBJoin(ByVal SourceArray As Variant, Optional ByVal Delimiter As Variant) As String
    
83.     VBJoin = ""
    
84.     On Error GoTo ErrTrap
    
85.     VBJoin = Join(SourceArray, Delimiter)
    
86.     Exit Function
    
87. 
    
88. ErrTrap:
    
89.     Debug.Print "VBJoin: " & Err.Number & ", " & Err.Description
    
90.     On Error GoTo 0
    
91. End Function
    
92. 
    
93. Public Function VBReplace(ByVal Expression As String, ByVal Find As String, ByVal ReplaceWith As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
    
94.     VBReplace = ""
    
95.     On Error GoTo ErrTrap
    
96.     VBReplace = Replace(Expression, Find, ReplaceWith, Start, Count, Compare)
    
97.     Exit Function
    
98. 
    
99. ErrTrap:
    
100.     Debug.Print "VBReplace: " & Err.Number & ", " & Err.Description
     
101.     On Error GoTo 0
     
102. End Function
     
103. 
     
104. Public Function VBRound(ByVal Number As Variant, Optional ByVal NumDigitsAfterDecimal As Long)
     
105.     VBRound = ""
     
106.     On Error GoTo ErrTrap
     
107.     VBRound = Round(Number, NumDigitsAfterDecimal)
     
108.     Exit Function
     
109. 
     
110. ErrTrap:
     
111.     Debug.Print "VBRound: " & Err.Number & ", " & Err.Description
     
112.     On Error GoTo 0
     
113. End Function
     
114. 
     
115. Public Function VBSplit(ByVal Expression As String, Optional ByVal Delimiter As Variant, Optional ByVal Limit As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant
     
116.     VBSplit = Empty
     
117.     On Error GoTo ErrTrap
     
118.     VBSplit = Split(Expression, Delimiter, Limit, Compare)
     
119.     Exit Function
     
120. 
     
121. ErrTrap:
     
122.     Debug.Print "VBSplit: " & Err.Number & ", " & Err.Description
     
123.     On Error GoTo 0
     
124. End Function
     
125.   [/FONT]
     

<br />   [FONT=courier new]<br /> Public Enum VbTriState<br />     vbFalse = 0<br />     vbTrue = -1<br />     vbUseDefault = -2<br /> End Enum<br /> <br /> Public Enum VbCompareMethod<br />     vbBinaryCompare = 0<br />     vbDatabaseCompare = 2<br />     vbTextCompare = 1<br /> End Enum<br /> <br /> Public Function VBFilter(ByVal SourceArray As Variant, ByVal Match As String, Optional ByVal Include As Boolean = True, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare)<br />     VBFilter = ""<br />     On Error GoTo ErrTrap<br />     VBFilter = Filter(SourceArray, Match, Include, Compare)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBFilter: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBFormatCurrency(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String<br />     VBFormatCurrency = ""<br />     On Error GoTo ErrTrap<br />     VBFormatCurrency = FormatCurrency(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBFormatCurrency: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBFormatDateTime(ByVal Expression As Variant, Optional ByVal NamedFormat As VbDateTimeFormat = vbGeneralDate) As String<br />     VBFormatDateTime = ""<br />     On Error GoTo ErrTrap<br />     VBFormatDateTime = FormatDateTime(Expression, NamedFormat)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBFormatDateTime: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBFormatNumber(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String<br />     VBFormatNumber = ""<br />     On Error GoTo ErrTrap<br />     VBFormatNumber = FormatNumber(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBFormatNumber: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBFormatPercent(ByVal Expression As Variant, Optional ByVal NumDigitsAfterDecimal As Long = -1, Optional ByVal IncludeLeadingDigit As VbTriState = vbUseDefault, Optional ByVal UseParensForNegativeNumbers As VbTriState = vbUseDefault, Optional ByVal GroupDigits As VbTriState = vbUseDefault) As String<br />     VBFormatPercent = ""<br />     On Error GoTo ErrTrap<br />     VBFormatPercent = FormatPercent(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBFormatPercent: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBInStrRev(ByVal StringCheck As String, StringMatch As String, Optional ByVal Start As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long<br />     VBInStrRev = ""<br />     On Error GoTo ErrTrap<br />     VBInStrRev = InStrRev(StringCheck, StringMatch, Start, Compare)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBInStrRev: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBJoin(ByVal SourceArray As Variant, Optional ByVal Delimiter As Variant) As String<br />     VBJoin = ""<br />     On Error GoTo ErrTrap<br />     VBJoin = Join(SourceArray, Delimiter)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBJoin: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBReplace(ByVal Expression As String, ByVal Find As String, ByVal ReplaceWith As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String<br />     VBReplace = ""<br />     On Error GoTo ErrTrap<br />     VBReplace = Replace(Expression, Find, ReplaceWith, Start, Count, Compare)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBReplace: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBRound(ByVal Number As Variant, Optional ByVal NumDigitsAfterDecimal As Long)<br />     VBRound = ""<br />     On Error GoTo ErrTrap<br />     VBRound = Round(Number, NumDigitsAfterDecimal)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBRound: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br /> <br /> Public Function VBSplit(ByVal Expression As String, Optional ByVal Delimiter As Variant, Optional ByVal Limit As Long = -1, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Variant<br />     VBSplit = Empty<br />     On Error GoTo ErrTrap<br />     VBSplit = Split(Expression, Delimiter, Limit, Compare)<br />     Exit Function<br /> <br /> ErrTrap:<br />     Debug.Print "VBSplit: " & Err.Number & ", " & Err.Description<br />     On Error GoTo 0<br /> End Function<br />   [/FONT]<br />

gufengyin

谢谢

zcmjw

正需要扩展数据进行操作的函数 。

houxianyong

不知道怎么利用，我有一堆数据是利用扩展数据的

秦林

斑竹先生,怎样修改实体上的扩展数据?能给个编程示例吗?