[分享]获取块属性标记的值和修改块属性标记的值
我是VBA初学者。最近在学习块属性时让我相当头痛。上网也没有查到太多这方面的资料，通过东拉西扯总算有所心得，我把学到的跟大家分享一下。Public Function GetArrTagVar(ArrName As String, TagCH As String) As String
'ArrName是块属性名称；TagCH是标记；
'返回块属性标签对应的值；
Dim attributeObj As AcadEntity
Dim ArrayCH As Variant
Dim Count As Integer
GetArrTagVar = "" '设置返回值"空",未找到块属性或未找到标记
On Error Resume Next
For Each attributeObj In ThisDrawing.ModelSpace
With attributeObj
If .Name = ArrName Then
If .HasAttributes Then
ArrayCH = .GetAttributes
For Count = LBound(ArrayCH) To UBound(ArrayCH)
If ArrayCH(Count).TagString = TagCH Then
GetArrTagVar = ArrayCH(Count).TextString
End If
Next Count
End If
End If
End With
Next attributeObj
End Function
Public Function SetArrTagVar(ArrName As String, TagCH As String, ValueCH As String) As Boolean 'ArrName是块属性名称；TagCH是标签；
'修改块属性标签对应的值；返回值是Boolean，Ture为修改成功，False为修改不成功;
Dim attributeObj As AcadEntity
Dim ArrayCH As Variant
Dim Count As Integer
SetArrTagVar = False '设置返回值"空",未找到块属必和未找到标签
On Error Resume Next
For Each attributeObj In ThisDrawing.ModelSpace
With attributeObj
If .Name = ArrName Then
If .HasAttributes Then
ArrayCH = .GetAttributes
For Count = LBound(ArrayCH) To UBound(ArrayCH)
If ArrayCH(Count).TagString = TagCH Then
ArrayCH(Count).TextString = ValueCH
SetArrTagVar = True
End If
Next Count
End If
End If
End With
Next attributeObj
End Function
页:
[1]