I haven’t posted anything of substance here for a while so I thought I’d share this…. I got bored yesterday and put this together
It’s a “Global” Attribute Editor which lists all blocks (containing attributes) in the current drawing.
When you select a block from the list, ( it also displays the layout) it displays the attributes associated with that block and from there you can modify the attribute value.
You can either
a) modify the attribute of only the selected block, or
b) modify ALL instances of that blocks attribute across all layouts
You also have the option to automatically switch to the selected blocks layout on selection and the option to zoom to the particular block you have selected
You can also apply a filter to list only blocks beginning with “abc” etc
You will need a Userform and the following controls :
Listboxes Name: LBblocks
Name: LBatts
Textboxes Name: TBfilter
Name: TBattvalue
Checkboxes Name: CBXgoto caption: “Go To layout On Selection”
Name: CBXzoom caption: “Zoom To Block On Selection” enabled: FALSE
Name: CBXallLayouts caption: “Apply To This Block On ALL Layouts”
Command Buttons Name: Cbfilter caption: “Apply Filter”
Name: CBclear caption: “Clear Filter”
Name: CBupdate caption: “Update Block(s)”
Name: CBexit caption: “Exit”
Labels caption: “Attribute Value”
caption: “Attribute List”
caption: “Block .. (some spaces)… Layout”
caption: “Show Only Blocks Beginning With…”
and a couple of Frames if you like to group the controls. I have 2 ~ one for “Block Filter” and one for “Block Details”
Next the code
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
not fully tested so use at your own risk yada yada yada
comments, suggestions welcomed
oh, and if you're lazy, here's the file......
