Changing block entities' color to bylayer

[sifuentes]

Hi, does any one know if there is a lisp routine that will redefine all blocks in a drawing, making it's nested object's properties bylayer?

Thanks,

Carlos Sifuentes

[mjfarrell]

REFEDIT will do this, only you will be required to
edit each different block in the drawing.
So for each 'chair' block and for each 'desk' block
you will need to REFEDIT them seperately.

[Mike.Perry]

Hi

The following comes from an old LISP Guild post by Peter Jamtgaard -


(defun C:FIXBLKS (/ ELST ENAM ESEL BNAM FLST)
(vl-load-com)
(setq ESEL (entsel "\nSelect block: ")
ENAM (car ESEL)
ELST (entget ENAM)
BNAM (cdr (assoc 2 ELST))
FLST nil
)
(fix1 BNAM)
(vl-cmdf "regen")
(prin1)
)
(defun FIX1 (BNAM / BENAM)
(if (not (member BNAM FLST))
(progn
(setq FLST (cons BNAM FLST)
BENAM (tblobjname "block" BNAM)
)
(while (setq BENAM (entnext BENAM))
(print (entget BENAM))
(if (= (cdr (assoc 0 (entget BENAM))) "INSERT")
(fix1 (cdr (assoc 2 (entget BENAM))))
(vla-put-color (vlax-ename->vla-object BENAM) 256)
)
)
)
)
)

The following comes from an old LISP Guild post by Ed Jobe -

I have a vba macro on the Exchange. It doesn't do blocks though. I just wrote another one to do blocks. I know they're not lisp, but they're free. :-)


Public Sub BlockEntsByLayer()
Dim oBlk As AcadBlock
Dim oBlk1 As AcadBlock
Dim oBlkRef As AcadBlockReference
Dim oBlkRef1 As AcadBlockReference
Dim oEnt As AcadEntity
Dim oEnt1 As AcadEntity
Dim ss As AcadSelectionSet

Set ss = toolbox.ejSelectionSets.GetSS_BlockFilter
For Each oBlkRef In ss
Set oBlk = ThisDrawing.Blocks(oBlkRef.Name)
If Not oBlk.IsXRef Then
For Each oEnt In oBlk
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef1 = oEnt
Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
For Each oEnt1 In oBlk1
With oEnt1
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
Next oEnt1
Else
With oEnt
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
End If
Next oEnt
End If
Next oBlkRef
ThisDrawing.Regen acAllViewports
End Sub

Have a good one, Mike

[GreyHippo]

GO TO MANUSOFT

http://www.manusoft.com/Software/Freebies/index.stm

check out the fixblock.lsp

[Hippigypsy]

THANKS, WILL DO.
I spend way too much time using refedit...but it's been a godsend.
Cathy

[sifuentes]

Thanks every body,

Carlos

[Mike.Perry]

The following comes from an old LISP Guild post by Ed Jobe -

I have a vba macro on the Exchange. It doesn't do blocks though. I just wrote another one to do blocks. I know they're not lisp, but they're free. :-)


Public Sub BlockEntsByLayer()
Dim oBlk As AcadBlock
Dim oBlk1 As AcadBlock
Dim oBlkRef As AcadBlockReference
Dim oBlkRef1 As AcadBlockReference
Dim oEnt As AcadEntity
Dim oEnt1 As AcadEntity
Dim ss As AcadSelectionSet

Set ss = toolbox.ejSelectionSets.GetSS_BlockFilter
For Each oBlkRef In ss
Set oBlk = ThisDrawing.Blocks(oBlkRef.Name)
If Not oBlk.IsXRef Then
For Each oEnt In oBlk
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef1 = oEnt
Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
For Each oEnt1 In oBlk1
With oEnt1
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
Next oEnt1
Else
With oEnt
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
End If
Next oEnt
End If
Next oBlkRef
ThisDrawing.Regen acAllViewports
End Sub
Hi Ed

Any chance you could post the relevant VBA Toolbox function or revise the code to have the ability to pick Block Objects?

Thanks, Mike

[Ed Jobe]

Actually, I was working on this just yesterday. I noticed that it didn't update the block's BlockBegin and BlockEnd objects. Here is the update and subroutines. Also note that this not only sets color to ByLayer, but sets the layer to "0". Also note that, in order for the Pickfirst selectionset to be recognized, this macro must not be run using VBARUN. You either have to use (vla-runmacro) or the RunMacro method of the application object.

You will also need VLAX.cls (http://forums.augi.com/attachment.php?attachmentid=4710). Unzip, save, and import into your dvb.



Public Sub BlockEntsByLayer()
Dim oBlk As AcadBlock
Dim oBlk1 As AcadBlock
Dim oBlkRef As AcadBlockReference
Dim oBlkRef1 As AcadBlockReference
Dim oEnt As AcadEntity
Dim oEnt1 As AcadEntity
Dim ss As AcadSelectionSet
Dim SeqEnd As AcadEntity
Dim blkent As AcadObject
Dim EntArray As Variant
Dim HasSEQE As Boolean

Set ss = GetSS_BlockFilter
For Each oBlkRef In ss
Set oBlk = ThisDrawing.Blocks(oBlkRef.Name)
If Not oBlk.IsXRef Then
'process BlockBegin and BlockEnd
HasSEQE = GetSeqEnd(oBlk, EntArray)
If HasSEQE = True Then
Set oEnt = EntArray(0)
oEnt.Layer = "0"
Set oEnt = EntArray(1)
oEnt.Layer = "0"
End If
For Each oEnt In oBlk
Set blkent = oBlk
'process sub ents
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef1 = oEnt
Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
For Each oEnt1 In oBlk1
With oEnt1
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
Next oEnt1
Else
With oEnt
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
End If
Next oEnt
End If
Next oBlkRef
ThisDrawing.Regen acAllViewports
End Sub

Public Sub AddSelectionSet(ss As AcadSelectionSet, SetName As String)
' This routine does the error trapping neccessary for when you want to create a
' selectin set. It takes the set and the proposed name and either adds it to the selectionsets
' collection or sets it.
On Error Resume Next
Set ss = ThisDrawing.SelectionSets.Add(SetName)
If Err.Number <> 0 Then
Set ss = ThisDrawing.SelectionSets.Item(SetName)
End If
End Sub


Public Function GetSS_BlockFilter() As AcadSelectionSet
'creates an ss of Blocks only
Dim s1 As AcadSelectionSet
Dim objEnts(0) As AcadEntity
Dim oEnt As AcadEntity
Dim lispCode As VLAX
Dim i As Integer

Dim intFtyp(0) As Integer ' setup for the filter
Dim varFval(0) As Variant
Dim varFilter1, varFilter2 As Variant
intFtyp(0) = 0: varFval(0) = "INSERT" ' get only blocks
varFilter1 = intFtyp: varFilter2 = varFval

'check for PickFirst selection set
Set s1 = ThisDrawing.PickfirstSelectionSet
If s1.Count > 0 Then
Set lispCode = Toolbox.CreateVLAXClass
'create a working ss in lisp environment
lispCode.EvalLispExpression "(setq ss (ssadd))"
For Each oEnt In s1
'transfer only blocks to the lisp ss
'here's where the filtering is done
If TypeOf oEnt Is AcadBlockReference Then
lispCode.EvalLispExpression "(ssadd " & _
"(handent " & Chr(34) & _
oEnt.Handle & Chr(34) & ")" & _
"ss" & _
")"
End If
Next oEnt
'clear orig pfss of ents, may contain other than text
s1.Clear
'set the pfss to the now filtered lisp ss
lispCode.EvalLispExpression "(sssetfirst nil ss)"
lispCode.EvalLispExpression "(setq ss nil)"
'transfer to a named ss and then deselect the pfss
AddSelectionSet s1, "ssBlockFilter"
Set s1 = ThisDrawing.PickfirstSelectionSet
lispCode.EvalLispExpression "(sssetfirst nil)"
Set lispCode = Nothing
Else
AddSelectionSet s1, "ssBlockFilter" ' create or get the set
s1.Clear ' clear the set
s1.SelectOnScreen varFilter1, varFilter2 ' do it
End If
Set GetSS_BlockFilter = s1

End Function


Public Function GetSeqEnd(objBlock As AcadBlock, EntArray As Variant) As Boolean
On Error GoTo Err_Control
'Returns True if BlockBegin or BlockEnd entities are found
'and returns them in the supplied array, a 2d array of AcadEnity.
Dim objSeqEnd As AcadEntity
Dim arySeqEnd(1) As AcadEntity
Dim strIHex As String
Dim strHandle As String
Dim strLeftHex As String
Dim strOwner As String

strHandle = objBlock.Handle
strLeftHex = Left(strHandle, Len(strHandle) - 2)
strIHex = "&H" & Right(objBlock.Handle, 2)
Do
ContLoop:
strIHex = strIHex + 1
Set objSeqEnd = _
ThisDrawing.HandleToObject(strLeftHex & Hex(strIHex))
strOwner = objSeqEnd.OwnerID
If objSeqEnd.ObjectName = "AcDbBlockBegin" Then
Set arySeqEnd(0) = objSeqEnd
GetSeqEnd = True
End If
If objSeqEnd.ObjectName = "AcDbBlockEnd" Then
Set arySeqEnd(1) = objSeqEnd
GetSeqEnd = True
Exit Do
End If
'Keep the loop from exceeding the reference members
Loop Until strOwner <> objBlock.ObjectID
If GetSeqEnd = True Then EntArray = arySeqEnd

Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case -2145386484
'Not a valid handle.
'This could be an older block that doesn't
'follow the pattern of BlockBegin's handle
'starting at 1 above the block handle.
'Continue the loop until you find it.
'BlockEnd should still be 1 above BlockBegin.
Resume ContLoop
Case Else
MsgBox Err.Number & ", " & Err.Description, , "GetSeqEnd"
Resume Exit_Here
End Select
End Function

[Mike.Perry]

Hi Ed

Thanks, will give it a go later tonight or sometime over the weekend.

:beer: Mike

[Mike.Perry]

Actually, I was working on this just yesterday. I noticed that it didn't update the block's BlockBegin and BlockEnd objects. Here is the update and subroutines. Also note that this not only sets color to ByLayer, but sets the layer to "0". Also note that, in order for the Pickfirst selectionset to be recognized, this macro must not be run using VBARUN. You either have to use (vla-runmacro) or the RunMacro method of the application object.



Public Function GetSS_BlockFilter() As AcadSelectionSet
'creates an ss of Blocks only
Dim s1 As AcadSelectionSet
Dim objEnts(0) As AcadEntity
Dim oEnt As AcadEntity
Dim lispCode As Toolbox.VLAX

Hi Ed

Am I correct in the use of (vla-RunMacro) -

(vla-RunMacro (vlax-Get-Acad-Object) "BlockEntsByLayer")

If yes, I get a "Compile Error: User-defined type not defined" message.

If no, could you please explain it's correct use.

Can you also please explain in simple English so even I can understand "RunMacro method of the application object".

:beer: Mike

[Ed Jobe]

I didn't catch that one. I didn't include VLAX, which is a class written by Frank Oquendo that allows you to run lisp from within vba. I used that to implement checking for the pickfirst ss. I'll attach the class for you to add to your dvb project.

[Mike.Perry]

Hi Ed

Please bear with me on this one -

I download the above ZIP file which contains VLAX.cls

Within AutoCAD opened the Visual Basic Editor (VBAIDE).

Open the VBA Project (DVB file) which was created from the code posted (http://forums.augi.com/showthread.php?p=60648#post60648); in the Project Explorer Window there's 1 Module (which contains the code posted (http://forums.augi.com/showthread.php?p=60648#post60648)).

From the "Insert" Pull Down Menu I choose "Class Module" -> "Class 1" is added to the Project Explorer Window under "Class Modules".

Right click "Class Modules", from right-click short-cut menu I choose "Import File" -> VLAX.cls

Highlight "Class 1", from right-click short-cut menu I choose "Remove Class 1".

Project Explorer Window now looks like the attached image file.

Close and Return to AutoCAD.

AutoCAD CommandLine: (vla-RunMacro (vlax-Get-Acad-Object) "BlockEntsByLayer")

I get the same Error as before. (http://forums.augi.com/showthread.php?p=60835#post60835)

Can you please explain what I'm doing wrong?

:beer: Mike

[Ed Jobe]

You need to change Toolbox.VLAX to just VLAX since you have the cls in the same dvb. Hope you don't have any more errors. When the Exchange comes back, I'll post a cleaned up version. I have my code organized in multiple dvb's and its suited for grabbing a single function and packaging it for distribution.

[Mike.Perry]

Hi Ed

Ok! I changed the line -

Dim lispCode As Toolbox.VLAX

to

Dim lispCode As VLAX

Is that correct?

Save -> Close and Return to AutoCAD.

AutoCAD CommandLine: (vla-RunMacro (vlax-Get-Acad-Object) "BlockEntsByLayer")

I now receive the following Error message (please see attached image).



You need to change Toolbox.VLAX to just VLAX since you have the cls in the same dvb.Is there another way of using VLAX.cls ?

I guess what I really mean, is there a better method than the one I used (am sure there is; as you know my VBA knowledge isn't worth talking about) ?

:beer: Mike

[Ed Jobe]

Sorry Mike.
Its not VLAX this time. I didn't include the AddSelectionSet function the first time. This is the kind of stuff I would check for before posting to the Exchange. I didn't have time to do that this time. Sorry you had to be the guinea pig. I just added it to where I put it the first time (http://forums.augi.com/showthread.php?p=60648#post60648) so if others copied it, they would get all the code.

[Mike.Perry]

Hi Ed

No worries and thanks for sticking with this (it's greatly appreciated).

Guess what - Yep I get an Error when I run the new code you posted (http://forums.augi.com/showthread.php?p=60648#post60648).

I removed the Class Module from the DVB file (Is that correct?).

I deleted all the code from the Module.

Copied in the new code you posted (http://forums.augi.com/showthread.php?p=60648#post60648) into the Module.

Save -> Close and Return to AutoCAD.

AutoCAD CommandLine: (vla-RunMacro (vlax-Get-Acad-Object) "BlockEntsByLayer")

I then receive the following Error message (please see attached images).

:beer: Mike

[Ed Jobe]

My bad, I'm not having a good week so far, am I? I copied it to the wrong place, try again. This should be the last time.

[Mike.Perry]

Hi Ed

Ok! good news :)

I copied the new code you posted (http://forums.augi.com/showthread.php?p=60648#post60648).

Deleted the old code in the Module.

Pasted in the new code.

Save -> Close and Return to AutoCAD.

Ran the macro, received an Error -

Dim lispCode As Toolbox.VLAX

Added back in the VLAX.cls Class Module

Changed the following line in the Module -

Dim lispCode As Toolbox.VLAX

to

Dim lispCode As VLAX

Save -> Close and Return to AutoCAD.

Ran the macro, worked like a charm.

Thanks once again for sticking with we on this one.

:beer: Mike

[Ed Jobe]

Great
I forgot we did that. I'll go back and fix that line in the post.

[aaboy]

Have you consulted your cad resource group lately...

[Ed Jobe]

Sorry, your question doesn't make sense.