This isn't exactly what you are looking for, but it should give you some
idea of how to iterate a block's entities.
Chuck
Sub OneLayer()
Dim strOneLayer As String
Dim intOneColor As Integer
Dim objGetXX As GetXX
Dim errGetXX As GetXX_Error_Code
Dim objEnt As AcadEntity
Dim objBlk As AcadBlock
Dim varAttribs As Variant
Dim i As Integer
Dim objAttrib As AcadAttributeReference
Set objGetXX = New GetXX
Set objGetXX.Application = Application
strOneLayer = objGetXX.GetString(errGetXX, False, "Enter a name for the
new layer: ", , 1)
If errGetXX = GETXX_ESCAPE Then GoTo Cancel
intOneColor = objGetXX.GetNumber(errGetXX, True, "Enter a color number
for the new layer: ", , 7)
If errGetXX = GETXX_ESCAPE Then GoTo Cancel
On Error Resume Next
ThisDrawing.Layers.Add (strOneLayer)
On Error GoTo 0
ThisDrawing.Layers(strOneLayer).Color = intOneColor
For Each objBlk In ThisDrawing.Blocks
If objBlk.IsXRef = False And InStr(1, objBlk.Name, "|",
vbTextCompare) = 0 Then
For Each objEnt In objBlk
If ThisDrawing.Layers(objEnt.Layer).Freeze = False Then
objEnt.Layer = strOneLayer
objEnt.Color = intOneColor
End If
Next
End If
Next
For Each objEnt In ThisDrawing.ModelSpace
If ThisDrawing.Layers(objEnt.Layer).Freeze = False Then
If TypeOf objEnt Is AcadBlockReference Then
varAttribs = objEnt.GetAttributes
For i = LBound(varAttribs) To UBound(varAttribs)
Set objAttrib = varAttribs(i)
objAttrib.Layer = strOneLayer
objAttrib.Color = intOneColor
Next i
End If
End If
Next
ThisDrawing.Regen acActiveViewport
For i = 1 To 3
ThisDrawing.PurgeAll
Next i
ThisDrawing.AuditInfo True
Cancel:
Set objAttrib = Nothing
Set objEnt = Nothing
Set objBlk = Nothing
Set objGetXX = Nothing
End Sub
"sedar" wrote in message
news:5ED78E1DD380E49F34A5C7CB907CC691@in.WebX.maYIadrTaRb...
> Hi
>
> I am trying to make a VBA program that can change layers from a color to
> bylayer.
>
> My problem is to get into a block that contains a block and then to change
> the layer to bylayer.
>
> I thing I have to make some kind of loop, but.....
>
> Anyone help.
>
>
>
>
