Jump to content

Lisp to change colour - Nested blocks


Recommended Posts

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!

 

 

example.JPG

Link to post
Share on other sites

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

Link to post
Share on other sites

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

 

Link to post
Share on other sites

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.  

 

image.png.8260cc1a4e01525a1e258adf3c3f0b75.png

 

image.png.d4b85027a2e5ca54a54e983fe7b4eb00.png #1) after executing your lisp

 

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

Link to post
Share on other sites

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

 

Link to post
Share on other sites

This lisp works great!

 

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

 

Roy! you the man!

 

Link to post
Share on other sites
  • 2 years later...
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 
 

Link to post
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...