Lisp to change colour - Nested blocks

[Sambuddy]

If anyone can help? 

I am trying to change the colour from one to another on blocks and nested blocks. Example: Change object colour (lines and plines and arcs and circles) 2 > 8 and 6 > 8 as well as changing hatch colour 8 > 9. It would be nice for the user to be able to have a selection window to select the blocks. I looked everywhere but cannot seem to find any lisp that cover nested blocks or change colour to another colour. I do not wish to change the object colours to by block or by layer. reminder that I do have other objects (lines etc...)in other colours within the same block that I do not want to change; that is the reason I would like specific object colours to change. 

 

Please help!

 

 

[BIGAL]

Have a look at this, there are many answers out there search a bit more.

 

[Sambuddy]

Thanks for your reply,

 

I did look a lot but unsuccessful! most cases change colors all together or to byblock and that is not what I am looking for.

 

thanks anyways

[Roy_043]

Try:

(defun KGA_Conv_Collection_To_List (coll / ret)
  (vl-remove
    nil
    (reverse
      (vlax-for a coll
        (setq ret (cons a ret))
      )
    )
  )
)

(defun KGA_Conv_Pickset_To_ObjectList (ss / i ret)
  (if ss
    (repeat (setq i (sslength ss))
      (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret))
    )
  )
)

; Change object color (lines and plines and arcs and circles) 2 > 8 and 6 > 8
; as well as change hatch color 8 > 9
(defun c:ChangeNestedColors ( / N_Modify N_Process blk blks blkToDoLst blkDoneLst doc lyrLckLst onm ss)

  (defun N_Modify (obj)
    (setq onm (vla-get-objectname obj))
    (cond
      ((vl-position onm '("AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbLine" "AcDbPolyline"))
        (if (vl-position (vla-get-color obj) '(2 6)) (vla-put-color obj 8))
      )
      ((= "AcDbHatch" onm)
        (if (= 8 (vla-get-color obj)) (vla-put-color obj 9))
      )
      ((vl-position onm '("AcDbBlockReference" "AcDbMInsertBlock"))
        (setq blk (vla-item blks (vla-get-name obj)))
        (if
          (and
            (not (vl-position blk blkDoneLst))
            (not (vl-position blk blkToDoLst))
          )
          (setq blkToDoLst (append blkToDoLst (list blk)))
        )
      )
    )
  )

  (defun N_Process (objLst)
    (setq blks (vla-get-blocks doc))
    (setq lyrLckLst
      (vl-remove-if
        '(lambda (lyr) (= :vlax-false (vla-get-lock lyr)))
        (KGA_Conv_Collection_To_List (vla-get-layers doc))
      )
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-false))
    (foreach obj objLst (N_Modify obj))
    (while blkToDoLst
      (if (= :vlax-false (vla-get-isxref (car blkToDoLst)))
        (vlax-for obj (car blkToDoLst)
          (N_Modify obj)
        )
      )
      (setq blkDoneLst (cons (car blkToDoLst) blkDoneLst))
      (setq blkToDoLst (cdr blkToDoLst))
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-true))
    (vla-regen doc acactiveviewport)
  )

  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-endundomark doc)
  (vla-startundomark doc)
  (if (setq ss (ssget '((0 . "INSERT"))))
    (N_Process (KGA_Conv_Pickset_To_ObjectList ss))
  )
  (vla-endundomark doc)
  (princ)
)

 

[Sambuddy]

Good morning Ray,

I have tried the lisp you have sent. Upon repeating the command over different blocks it looks that hatch does not seem to work in some instances. You can see on snapshots I attached. especially in second and third pictures: it seems that your lisp changes the hatch and line colours but as soon as I open the block editor something strange happens; that is hatch changes to its original colour and line colours change to their original colour when I save the block.

 

Could you please do your magic again and see what the problem is:

 

in general I would like all colours under blocks and nested blocks for lines/plines/arc/circles 2 > 0 and 6 > 8 and 31 > 8,  and all hatches blocks and nested blocks to be 8 > 9 and 6 > 8.

 

please help!

 

the snapshots you see below are after executing your lisp.  

 

 

 #1) after executing your lisp

 

 #2) after I open block editor. It seems to stay that way when I save 

[Roy_043]

The code did not consider dynamic blocks and their anonymous 'offspring'. You have changed the colors a bit. Are you sure about '2 > 0' (0 = ByBlock)?

Anyway here is the new code:

; blkObj = Block definition object.
; Return value: List of block definition objects with the same effective name belonging to the same blocks object or nil (block is not dynamic).
(defun KGA_Block_DynDefinitionList (blkObj / hnd ret)
  (if
    (setq hnd
      (cond
        ((= :vlax-true (vla-get-isdynamicblock blkObj))
          (vla-get-handle blkObj)
        )
        ((wcmatch (vla-get-name blkObj) "`*[Uu]*")
          (cdr (assoc 1005 (cdadr (assoc -3 (entget (vlax-vla-object->ename blkObj)'("AcDbBlockRepBTag"))))))
        )
      )
    )
    (progn
      (vlax-for blkObj (KGA_Sys_ObjectOwner blkObj)
        (cond
          ((= hnd (vla-get-handle blkObj))
            (setq ret (cons blkObj ret))
          )
          (
            (and
              (wcmatch (vla-get-name blkObj) "`*[Uu]*")
              (= hnd (cdr (assoc 1005 (cdadr (assoc -3 (entget (vlax-vla-object->ename blkObj)'("AcDbBlockRepBTag")))))))
            )
            (setq ret (cons blkObj ret))
          )
        )
      )
      (reverse ret)
    )
  )
)

(defun KGA_Conv_Collection_To_List (coll / ret)
  (vl-remove
    nil
    (reverse
      (vlax-for a coll
        (setq ret (cons a ret))
      )
    )
  )
)

(defun KGA_Conv_Pickset_To_ObjectList (ss / i ret)
  (if ss
    (repeat (setq i (sslength ss))
      (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret))
    )
  )
)

(defun KGA_Sys_ObjectOwner (obj)
  (vla-objectidtoobject (vla-get-database obj) (vla-get-ownerid obj))
)

; Lines/plines/arc/circles:
;  2 > 0
;  6 > 8
; 31 > 8
; Hatches:
;  6 > 8
;  8 > 9
(defun c:ChangeNestedColors ( / N_Modify N_Process blk blks blkToDoLst blkDoneLst doc lyrLckLst onm ss)

  (defun N_Modify (obj)
    (setq onm (vla-get-objectname obj))
    (cond
      ((vl-position onm '("AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbLine" "AcDbPolyline"))
        (cond
          ((=  2 (vla-get-color obj)) (vla-put-color obj 0)) ; ByBlock?
          ((=  6 (vla-get-color obj)) (vla-put-color obj 8))
          ((= 31 (vla-get-color obj)) (vla-put-color obj 8))
        )
      )
      ((= "AcDbHatch" onm)
        (cond
          ((=  6 (vla-get-color obj)) (vla-put-color obj 8))
          ((=  8 (vla-get-color obj)) (vla-put-color obj 9))
        )
      )
      ((vl-position onm '("AcDbBlockReference" "AcDbMInsertBlock"))
        (setq blk (vla-item blks (vla-get-name obj)))
        (foreach blk (cond ((KGA_Block_DynDefinitionList blk)) ((list blk)))
          (if
            (and
              (not (vl-position blk blkDoneLst))
              (not (vl-position blk blkToDoLst))
            )
            (setq blkToDoLst (append blkToDoLst (list blk)))
          )
        )
      )
    )
  )

  (defun N_Process (objLst)
    (setq blks (vla-get-blocks doc))
    (setq lyrLckLst
      (vl-remove-if
        '(lambda (lyr) (= :vlax-false (vla-get-lock lyr)))
        (KGA_Conv_Collection_To_List (vla-get-layers doc))
      )
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-false))
    (foreach obj objLst (N_Modify obj))
    (while blkToDoLst
      (if (= :vlax-false (vla-get-isxref (car blkToDoLst)))
        (vlax-for obj (car blkToDoLst)
          (N_Modify obj)
        )
      )
      (setq blkDoneLst (cons (car blkToDoLst) blkDoneLst))
      (setq blkToDoLst (cdr blkToDoLst))
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-true))
    (vla-regen doc acactiveviewport)
  )

  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-endundomark doc)
  (vla-startundomark doc)
  (if (setq ss (ssget '((0 . "INSERT"))))
    (N_Process (KGA_Conv_Pickset_To_ObjectList ss))
  )
  (vla-endundomark doc)
  (princ)
)

 

[Sambuddy]

This lisp works great!

 

Thank you for your hard work and capturing what I was trying to achieve.

 

Roy! you the man!

 

[wintxilin]

On 10/4/2019 at 4:54 PM, Roy_043 said:

The code did not consider dynamic blocks and their anonymous 'offspring'. You have changed the colors a bit. Are you sure about '2 > 0' (0 = ByBlock)?

Anyway here is the new code:

; blkObj = Block definition object.
; Return value: List of block definition objects with the same effective name belonging to the same blocks object or nil (block is not dynamic).
(defun KGA_Block_DynDefinitionList (blkObj / hnd ret)
  (if
    (setq hnd
      (cond
        ((= :vlax-true (vla-get-isdynamicblock blkObj))
          (vla-get-handle blkObj)
        )
        ((wcmatch (vla-get-name blkObj) "`*[Uu]*")
          (cdr (assoc 1005 (cdadr (assoc -3 (entget (vlax-vla-object->ename blkObj)'("AcDbBlockRepBTag"))))))
        )
      )
    )
    (progn
      (vlax-for blkObj (KGA_Sys_ObjectOwner blkObj)
        (cond
          ((= hnd (vla-get-handle blkObj))
            (setq ret (cons blkObj ret))
          )
          (
            (and
              (wcmatch (vla-get-name blkObj) "`*[Uu]*")
              (= hnd (cdr (assoc 1005 (cdadr (assoc -3 (entget (vlax-vla-object->ename blkObj)'("AcDbBlockRepBTag")))))))
            )
            (setq ret (cons blkObj ret))
          )
        )
      )
      (reverse ret)
    )
  )
)

(defun KGA_Conv_Collection_To_List (coll / ret)
  (vl-remove
    nil
    (reverse
      (vlax-for a coll
        (setq ret (cons a ret))
      )
    )
  )
)

(defun KGA_Conv_Pickset_To_ObjectList (ss / i ret)
  (if ss
    (repeat (setq i (sslength ss))
      (setq ret (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) ret))
    )
  )
)

(defun KGA_Sys_ObjectOwner (obj)
  (vla-objectidtoobject (vla-get-database obj) (vla-get-ownerid obj))
)

; Lines/plines/arc/circles:
;  2 > 0
;  6 > 8
; 31 > 8
; Hatches:
;  6 > 8
;  8 > 9
(defun c:ChangeNestedColors ( / N_Modify N_Process blk blks blkToDoLst blkDoneLst doc lyrLckLst onm ss)

  (defun N_Modify (obj)
    (setq onm (vla-get-objectname obj))
    (cond
      ((vl-position onm '("AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbLine" "AcDbPolyline"))
        (cond
          ((=  2 (vla-get-color obj)) (vla-put-color obj 0)) ; ByBlock?
          ((=  6 (vla-get-color obj)) (vla-put-color obj 8))
          ((= 31 (vla-get-color obj)) (vla-put-color obj 8))
        )
      )
      ((= "AcDbHatch" onm)
        (cond
          ((=  6 (vla-get-color obj)) (vla-put-color obj 8))
          ((=  8 (vla-get-color obj)) (vla-put-color obj 9))
        )
      )
      ((vl-position onm '("AcDbBlockReference" "AcDbMInsertBlock"))
        (setq blk (vla-item blks (vla-get-name obj)))
        (foreach blk (cond ((KGA_Block_DynDefinitionList blk)) ((list blk)))
          (if
            (and
              (not (vl-position blk blkDoneLst))
              (not (vl-position blk blkToDoLst))
            )
            (setq blkToDoLst (append blkToDoLst (list blk)))
          )
        )
      )
    )
  )

  (defun N_Process (objLst)
    (setq blks (vla-get-blocks doc))
    (setq lyrLckLst
      (vl-remove-if
        '(lambda (lyr) (= :vlax-false (vla-get-lock lyr)))
        (KGA_Conv_Collection_To_List (vla-get-layers doc))
      )
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-false))
    (foreach obj objLst (N_Modify obj))
    (while blkToDoLst
      (if (= :vlax-false (vla-get-isxref (car blkToDoLst)))
        (vlax-for obj (car blkToDoLst)
          (N_Modify obj)
        )
      )
      (setq blkDoneLst (cons (car blkToDoLst) blkDoneLst))
      (setq blkToDoLst (cdr blkToDoLst))
    )
    (foreach lyr lyrLckLst (vla-put-lock lyr :vlax-true))
    (vla-regen doc acactiveviewport)
  )

  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-endundomark doc)
  (vla-startundomark doc)
  (if (setq ss (ssget '((0 . "INSERT"))))
    (N_Process (KGA_Conv_Pickset_To_ObjectList ss))
  )
  (vla-endundomark doc)
  (princ)
)

 

is it working actually? i'm not capable of running it, not sure if it's because its outdated or i am typing the command wrong? (kga....)
i'm new with this lisp thing 
 

[BIGAL]

Try typing ChangeNestedColors

[Anakozza]

Dear all, How can i change all nested objects inside block (not Xref) in one click:

 

color byLayer,

Layer 0

ltype bylayer

ltypescale 1

lineweight bylayer

transparency bylayer

thickness 0

 

Thank you in advance