[分享]获取块属性标记的值和修改块属性标记的值

chh_7

我是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