全局属性编辑器

Option Explicit
    Dim Block1Atts As Variant
    Dim Block1 As AcadBlockReference
Private Sub CBclear_Click()
    
' clear the filter and display all blocks with attributes
    LBblocks.Clear
    TBfilter.Text = ""
    
    Dim LO As AcadLayout
    Dim Ent As AcadEntity
    Dim Blk As AcadBlock
    
        For Each LO In ThisDrawing.Layouts
            For Each Ent In LO.Block
                If TypeOf Ent Is AcadBlockReference Then
                    Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
                    If Ent.HasAttributes = True Then
                        LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
                    End If
                End If
            Next
        Next
' sort the listbox
    LBsort LBblocks
    
End Sub
Private Sub CBexit_Click()
    Unload Me
End Sub
Private Sub CBfilter_Click()
    LBblocks.Clear
    
    Dim LO As AcadLayout
    Dim Ent As AcadEntity
    Dim Blk As AcadBlock
' if the block name matches the filter text(with wildcard)
        For Each LO In ThisDrawing.Layouts
            For Each Ent In LO.Block
                If TypeOf Ent Is AcadBlockReference Then
                    Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
                    If Ent.Name Like UCase(TBfilter.Text) & "*" Then
                        If Ent.HasAttributes = True Then
                            LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
                        End If
                    End If
                End If
            Next
        Next
    
    LBsort LBblocks
    
End Sub
Private Sub CBupdate_Click()
   
    Dim BLKcoll As AcadSelectionSets
    Dim SSetBlks As AcadSelectionSet
    Dim NxtBlk As AcadBlockReference
    Dim BlkAtts As Variant
    
        Dim X As Integer
' if we are only updating the selected block then....
        If CBXallLayouts.Value = False Then
            For X = 0 To UBound(Block1Atts)
                If LBatts.Value = Block1Atts(X).TagString Then
                     Block1Atts(X).TextString = TBattValue.Text
                End If
            Next X
            Block1.Update
            Exit Sub
        Else
' or if we are updating this block across ALL layouts then...
' first check if any ss exist and if they do, delete them
            Set BLKcoll = ThisDrawing.SelectionSets
                For Each SSetBlks In BLKcoll
                    If SSetBlks.Name = "SSbks" Then
                        ThisDrawing.SelectionSets.Item("SSbks").Delete
                        Exit For
                    End If
                Next
' then get an SS of the blocks
            Set SSetBlks = ThisDrawing.SelectionSets.Add("SSbks")
                Dim FilterType(0 To 1) As Integer
                Dim FilterData(0 To 1) As Variant
                FilterType(0) = 0: FilterData(0) = "INSERT"
                FilterType(1) = 2: FilterData(1) = Block1.Name
            SSetBlks.Select acSelectionSetAll, , , FilterType, FilterData
' loop through the Sset, get attributes and apply the updated value to the attribute
            For Each NxtBlk In SSetBlks
                BlkAtts = NxtBlk.GetAttributes
                For X = 0 To UBound(BlkAtts)
                    If BlkAtts(X).TagString = LBatts.Value Then
                        BlkAtts(X).TextString = TBattValue.Text
                        NxtBlk.Update
                    End If
                Next X
            Next NxtBlk
            ThisDrawing.SelectionSets.Item("SSbks").Delete
        End If
' and clear the global checkbox
            CBXallLayouts.Value = False
            
End Sub
Private Sub CBXgoto_Click()
    If CBXgoto.Value = True Then
        CBXzoom.Enabled = True
    ElseIf CBXgoto.Value = False Then
        CBXzoom.Enabled = False
    End If
End Sub
Private Sub LBatts_Click()
' dispay the attribute value when clicked
    Dim X As Integer
        For X = 0 To UBound(Block1Atts)
            If LBatts.Value = Block1Atts(X).TagString Then
                TBattValue.Text = Block1Atts(X).TextString
            End If
        Next X
            
End Sub
Private Sub LBblocks_Click()
TBattValue.Text = ""
    Dim BlockName As String
    Dim LayoutName As String
    Dim BlValue As Variant
' split the text into block name and layout name
        BlValue = LBblocks.Value
        BlValue = Split(BlValue, vbTab, , vbTextCompare)
        BlockName = BlValue(0)
        LayoutName = BlValue(1)
        
    Dim BLKcoll As AcadSelectionSets
    Dim SSetBlks As AcadSelectionSet
' first check if any ss exist and if they do, delete them
    Set BLKcoll = ThisDrawing.SelectionSets
         For Each SSetBlks In BLKcoll
             If SSetBlks.Name = "SSbks" Then
             ThisDrawing.SelectionSets.Item("SSbks").Delete
         Exit For
         End If
     Next
' then get an SS of the blocks
    Set SSetBlks = ThisDrawing.SelectionSets.Add("SSbks")
        Dim FilterType(0 To 1) As Integer
        Dim FilterData(0 To 1) As Variant
        FilterType(0) = 0: FilterData(0) = "INSERT"
        FilterType(1) = 2: FilterData(1) = BlockName
    SSetBlks.Select acSelectionSetAll, , , FilterType, FilterData
' filter for the block on the current layout
    FilterLayout SSetBlks, LayoutName
' display the block tag string
    Dim i As Integer
        Set Block1 = SSetBlks.Item(0)
            'If Block1.HasAttributes = True Then
                LBatts.Clear
                Block1Atts = Block1.GetAttributes
                    For i = 0 To UBound(Block1Atts)
                        LBatts.AddItem Block1Atts(i).TagString
                    Next i
            'End If
        ThisDrawing.SelectionSets.Item("SSbks").Delete
        
' if "Go to layout on selection" is checked then
        If CBXgoto.Value = True Then
            ThisDrawing.ActiveLayout = ThisDrawing.Layouts(LayoutName)
' if "Zoom to block on selection" is checked then get the bounding box of the block
                If CBXzoom.Value = True Then
                    Dim BboxSP As Variant
                    Dim BboxEP As Variant
                        Block1.GetBoundingBox BboxSP, BboxEP
' and use the bounding box for a zoom window
                    Dim BboxP1(0 To 2) As Double
                    Dim BboxP2(0 To 2) As Double
                        BboxP1(0) = BboxSP(0): BboxP1(1) = BboxSP(1): BboxP1(2) = BboxSP(2)
                        BboxP2(0) = BboxEP(0): BboxP2(1) = BboxEP(1): BboxP2(2) = BboxEP(2)
                        ZoomWindow BboxP1, BboxP2
                End If
        End If
End Sub
Private Sub UserForm_Initialize()
' find all blocks in drawing and if they have attributes
' then add them to the listbox
    Dim LO As AcadLayout
    Dim Ent As AcadEntity
    Dim Blk As AcadBlock
    
        For Each LO In ThisDrawing.Layouts
            For Each Ent In LO.Block
                If TypeOf Ent Is AcadBlockReference Then
                    Set Blk = ThisDrawing.ObjectIdToObject(Ent.OwnerID)
                    If Ent.HasAttributes = True Then
                        LBblocks.AddItem UCase(Ent.Name & vbTab & Blk.Layout.Name)
                    End If
                End If
            Next
        Next
' and sort the listbox
    LBsort LBblocks
    
End Sub
Private Function LBsort(LB As ListBox)
' Sort the listbox
    Dim LBvar As Variant
    Dim i As Integer
    
    For i = 0 To LB.ListCount - 2
        If LB.List(i) > LB.List(i + 1) Then
            LBvar = LB.List(i)
            LB.List(i) = LB.List(i + 1)
            LB.List(i + 1) = LBvar
            i = -1
        End If
    Next i
End Function
Private Sub FilterLayout(SS As AcadSelectionSet, LOname As String)
' from code on Autodesk.com by Frank Oquendo
    Dim X As Integer
    Dim ObjArray() As AcadEntity
    Dim Max As Long
        Max = -1
    For X = 0 To SS.Count - 1
        If LCase(ThisDrawing.ObjectIdToObject(SS.Item(X).OwnerID).Layout.Name)  LCase(LOname) Then
            Max = Max + 1
            ReDim Preserve ObjArray(0 To Max)
            Set ObjArray(Max) = SS.Item(X)
        End If
    Next X
    SS.RemoveItems ObjArray
End Sub