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. 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.

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".

Mike