Blocks with Attributes

I am new to AutoCAD VBA, I was wondering if anyone could help me. I am trying to write a Procedure that will loop through all the blocks, included nested blocks, in a drawing and change it objects, include attribute tags, to the color ByLayer. I am running AutoCAD 2000i Any help would be appreciated.

Thanks,
Joe

 

Public Sub changeBlockColor(colorValue As Integer)
Dim block As AcadBlock
Dim entity As AcadEntity

For Each block In ThisDrawing.Blocks
For Each entity In block
entity.color = colorValue
Next entity
Next block
End Sub

Public Sub testChangeBlockColor()
changeBlockColor acByLayer
End Sub

 

Hi Joe,
This is a two step process. The first is to find all block definitions and
change all of the entities defined within to color bylayer. The second step
is to grab all block references and change all of their attribute references
to color bylayer. Of course the tricky part there is the nested block
condition. The first listing here takes care of step one.

Public Sub MakeColorByLayer(acadDB As AcadDatabase)
Dim block As AcadBlock
Dim ent As AcadEntity

For Each block In acadDB.Blocks
If Not block.IsLayout And Not block.IsXRef Then
For Each ent In block
ent.Color = acByLayer
Next ent
End If
Next block
End Sub

This next listing handles the second step. I chose a recursive function
here to handle the nested blocks. I seriously doubt that anyone has blocks
nested deep enough where there would be a difference enough to warrant
coding up an iterative function to handle this. Also note that I didn't
account for constant attributes.

Public Sub MakeAttRefsColorByLayer(blockRef As AcadBlockReference)
Dim acadDoc As AcadDocument
Set acadDoc = blockRef.Document

Dim blockName As String
blockName = blockRef.Name

Dim blockDef As AcadBlock
Set blockDef = acadDoc.Blocks.Item(blockName)

'Test if the block is a simple block.
If Not blockDef.IsLayout And Not blockDef.IsXRef Then
Dim attRefs As Variant
Dim attRef As AcadAttributeReference
Dim attRefIndex As Integer

'Set all of the attributes to color bylayer
If blockRef.HasAttributes Then
attRefs = blockRef.GetAttributes()
For attRefIndex = LBound(attRefs) To UBound(attRefs)
Set attRef = attRefs(attRefIndex)
attRef.Color = acByLayer
Next attRefIndex
End If

'Check for nested blocks
Dim ent As AcadEntity
Dim nestedBlockRef As AcadBlockReference
For Each ent In blockDef
If TypeOf ent Is AcadBlockReference Then
'Make recursive call to handle nested blocks
Set nestedBlockRef = ent
Call MakeAttRefsColorByLayer(nestedBlockRef)
End If
Next ent
End If
End Sub

You can run these two functions like this. For the sake of simplicity I am
iterating all of the layouts in search of block references, but you could
just as easily create a filtered selection set if you so desired.

Public Sub TestMakeColorByLayer()
'Step one
Call MakeColorByLayer(ThisDrawing.Database)

'Step Two
Dim layout As AcadLayout
Dim ent As AcadEntity
Dim blockRef As AcadBlockReference

For Each layout In ThisDrawing.Layouts
For Each ent In layout.block
If TypeOf ent Is AcadBlockReference Then
Set blockRef = ent
Call MakeAttRefsColorByLayer(blockRef)
End If
Next ent
Next layout
End Sub

I also just caught the fact that you are on 2000i. My original code was
created in 2004 and utilized the new true color object. I'm pretty sure
that I ripped all of that out and replaced all of the TrueColor property
calls to the Color property, but it's not tested as such. Let me know if
you have any problems.
--
Bobby C. Jones
www.AcadX.com

trying to write a Procedure that will loop through all the blocks, included
nested blocks, in a drawing and change it objects, include attribute tags,
to the color ByLayer. I am running AutoCAD 2000i Any help would be
appreciated.

 

Just for the record, This is not a "two step process",
and you don't need to worry about 'nested' blocks or
application of 'recursive' concepts, because you're
going to process *all* objects in the drawing, except
for those in layouts.

In fact, the "recursive approach" posted in another
reply, will needlessly process the same block multiple
times, when insertions of it appear in more than one
parent block. Duh!

This Sub will process every block, including layouts,
but will not change the color of entities that are
directly owned by layouts:

Public Sub ProcessBlock(Block As AcadBlock)
Dim IsNested As Boolean
IsNested = not Block.IsLayout
Dim Entity As AcadEntity
ForEach Entity in Block
If IsNested then
Entity.Color = acByLayer
End If
if TypeOf Entity is AcadBlockReference then
Dim BlockRef As AcadBlockReference
Set BlockRef = Entity
If BlockRef.HasAttributes then
Dim AttRef As AcadAttributeReference
Dim Attributes As Variant
Attributes = BlockRef.GetAttributes
Dim i As Integer
For i = LBound(Attributes) to UBound(Attributes)
Set AttRef = Attributes(i)
AttRef.Color = acByLayer
Next i
End If
End If
Next Entity
End Sub

With the above, you just need this:

Public Sub ProcessDrawing
Dim ABlock As AcadBlock
ForEach ABlock in ThisDrawing.Blocks
If not ABlock.IsXref then
ProcessBlock ABlock
End if
Next Block
End Sub

through all the blocks, included nested blocks, in a drawing and change it objects, include attribute tags, to the color
ByLayer. I am running AutoCAD 2000i Any help would be appreciated.

 

Note that both of those subs were not tested
at all, and there's a stupid bug in the second
sub:

Public Sub ProcessDrawing
Dim ABlock As AcadBlock
ForEach ABlock in ThisDrawing.Blocks
If not ABlock.IsXref then
ProcessBlock ABlock
End if
Next ABlock ' bug fixed
End Sub

 

Big Duh indeed T man! What was the other poster, or is that poser, thinking
Thanks for the simplified answer.
--
Bobby C. Jones
www.AcadX.com

trying to write a Procedure that will loop

objects, include attribute tags, to the color

 

Nice. And at the risk of gittin stomped ;-)

There is also the matter of possible constant attributes
that would be handled similarly with getconstantattributes.