Change Block Color based on Block Name

[CAD_Noob]

Hi all Lisp Guru!

Do you guys have any available lisp wherein I can set the Block color based on the Block name?

I have exported a Revit model to AutoCAD which contains multiple discipline.

In AutoCAD it will all become a block.

What I want is have a pre-defined color based on the discipline.

 

Example (if Block name contains the following)

 

ARCHI - Color =8

MECHD - Color=1

MECHW - Color=2

 

and so on...

 

[Steven P]

I have this as a start for you. I copied the basis from this from somewhere - either this forum of from Lee Mac (I lost the reference, happy to refer to it if anyone knows).

 

Command attnorm puts most blocks as layer 0 and colour byblock.

 

If it was me I would put the blocks on appropriate layers, Arch, MechD, MechW and so on, and use layer colours for the block colours.. then your question will be how to move blocks to a layer dependent on name?

 

 

(defun c:attnorm (/ myblocklayer myblockcolour myblocklineweight myblocklinetype)
  (setq myblocklayer "0")
  (setq myblockcolour 0)
;  (setq myblocklineweight aclnwtbyblock)
;  (setq myblocklinetype "byblock")
  (mynorm myblocklayer myblockcolour myblocklineweight myblocklinetype)
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:attnormred (/ myblocklayer myblockcolour myblocklineweight myblocklinetype)
  (setq myblocklayer "0")
  (setq myblockcolour 10)
;  (setq myblocklineweight aclnwtbyblock)
;  (setq myblocklinetype "byblock")
  (mynorm myblocklayer myblockcolour myblocklineweight myblocklinetype)
  (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun mynorm (myblocklayer myblockcolour myblocklineweight myblocklinetype / *error* adoc lst_layer func_restore-layers)
  (defun *error* (msg)
    (func_restore-layers)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
  ) ;_ end of defun

  (defun func_restore-layers ()
    (foreach item lst_layer
      (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
      (vl-catch-all-apply
        '(lambda ()
           (vla-put-freeze
             (car item)
             (cdr (assoc "freeze" (cdr item)))
           ) ;_ end of vla-put-freeze
         ) ;_ end of lambda
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of foreach
  ) ;_ end of defun

  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  ) ;_ end of vla-startundomark

  (if (and (not (vl-catch-all-error-p
          (setq selset
            (vl-catch-all-apply
              (function
                (lambda ()
                  (ssget '((0 . "INSERT")))
                ) ;_ end of lambda
              ) ;_ end of function
            ) ;_ end of vl-catch-all-apply
          ) ;_ end of setq
       ) ;_ end of vl-catch-all-error-p
      ) ;_ end of not
    selset
    ) ;_ end of and
    (progn
      (vlax-for item (vla-get-layers adoc)
        (setq
          lst_layer (cons (list item
                (cons "lock" (vla-get-lock item))
                (cons "freeze" (vla-get-freeze item))
              ) ;_ end of list
              lst_layer
          ) ;_ end of cons
        ) ;_ end of setq
        (vla-put-lock item :vlax-false)
        (vl-catch-all-apply
          '(lambda () (vla-put-freeze item :vlax-false))
        ) ;_ end of vl-catch-all-apply
      ) ;_ end of vlax-for
      (foreach blk_def
        (mapcar
          (function
            (lambda (x)
              (vla-item (vla-get-blocks adoc) x)
            ) ;_ end of lambda
          ) ;_ end of function
          ((lambda (/ res)
              (foreach item (mapcar
                (function
                  (lambda (x)
                    (vla-get-name
                      (vlax-ename->vla-object x)
                    ) ;_ end of vla-get-name
                  ) ;_ end of lambda
                ) ;_ end of function
                ((lambda (/ tab item)
                    (repeat (setq tab  nil
                        item (sslength selset)
                      ) ;_ end setq
                      (setq
                        tab
                        (cons
                          (ssname selset
                            (setq item (1- item))
                          ) ;_ end of ssname
                          tab
                        ) ;_ end of cons
                      ) ;_ end of setq
                    ) ;_ end of repeat
                    tab
                  ) ;_ end of lambda
                )
              ) ;_ end of mapcar
              (if (not (member item res))
                (setq res (cons item res))
              ) ;_ end of if
              ) ;_ end of foreach
              (reverse res)
            ) ;_ end of lambda
          )
        ) ;_ end of mapcar
        (vlax-for ent blk_def

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Sets the block attributes
;;add in here other attributes to change
          (vla-put-layer ent myblocklayer)
          (vla-put-color ent myblockcolour)
;;          (vla-put-lineweight ent myblocklineweight)
;;          (vla-put-linetype ent myblocklinetype)
;;end of setting up block attributes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        ) ;_ end of vlax-for
      ) ;_ end of foreach
      (func_restore-layers)
      (vla-regen adoc acallviewports)
    ) ;_ end of progn
  ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
);_ end of defun

 

[CAD_Noob]

I can use SETBYLAYER to turn all blocks to ByLayer and Layer 0 right?

 

and then use your lisp? is that what you mean?

 

(DEFUN C:C8 (/) 
(COMMAND "._layer" "C" "8" "*AR*" "")

This is what I tried if by layer...

If by layer I think it will be confusing so I prefer it it's via block name without user selection if possible

 

Edited August 1, 2023 by CAD_Noob

[Steven P]

I prefer the make up of the block to be layer 0 and ByBlock rather than ByLayer.

 

Afterwards I would select the blocks with ssget, to select blocks with MECHD in the name

 

(setq MySS (ssget '((0 . "INSERT")(2 . "*MECHD"))))

 

Something in here to work though to move them to the correct layer, tolayer from VVA using the selection set above

 

Let us know how you get on with that idea and if you need more guidance

 

 

[nod684]

You can use Quick Select > Block reference. 

under Properties, select NAME

in Operator, select *widlcard Match then enter the value *MECH*

 

then just change the color from the pulldown..

 

 

[CAD_Noob]

14 hours ago, nod684 said:

You can use Quick Select > Block reference. 

under Properties, select NAME

in Operator, select *widlcard Match then enter the value *MECH*

 

then just change the color from the pulldown..

 

Yes that is what I am doing currently.

Hoping to have this process via lisp so color is automatically set

 

Edited August 3, 2023 by CAD_Noob

[mhupp]

See if this does anything

 

(defun C:foo (/ name)
  (vl-load-com)
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))  ;lists all block definitions in the drawing
    (cond
      ((wcmatch (setq name (vla-get-name blk)) "*ARCHI*") ;if block name contains this string
        (vlax-for obj blk        ;step though each entity in the block
          (vla-put-color obj 8)  ;and change its coloer to 8
        )
      )
      ((wcmatch name "*MECHD*")
        (vlax-for obj blk  
          (vla-put-color obj 1)
        )
      )
      ((wcmatch name "*MECHW*")
        (vlax-for obj blk  
          (vla-put-color obj 2)
        )
      )
    )
  )
  (vla-Regen doc acAllViewports)
  (vla-endundomark doc)
  (princ)
)

 

Edited August 3, 2023 by mhupp

[CAD_Noob]

1 hour ago, mhupp said:

See if this does anything

 

(defun C:foo (/ name)
  (vl-load-com)
  (vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for blk (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))  ;lists all block definitions in the drawing
    (cond
      ((wcmatch (setq name (vla-get-name blk)) "*ARCHI*") ;if block name contains this string
        (vlax-for obj blk        ;step though each entity in the block
          (vla-put-color obj 8)  ;and change its coloer to 8
        )
      )
      ((wcmatch name "*MECHD*")
        (vlax-for obj blk  
          (vla-put-color obj 8)
        )
      )
      ((wcmatch name "*MECHW*")
        (vlax-for obj blk  
          (vla-put-color obj 8)
        )
      )
    )
  )
  (vla-Regen doc acAllViewports)
  (vla-endundomark doc)
  (princ)
)

 

 

Thank you so much @mhupp, it works... but only change the color of the parent block...

nested blocks are not changed maybe because nested block name is not in the condition list?

[mhupp]

That should get all blocks even if they are nested. but if the nested blocks don't have those strings in their name it won't change color.

 

-edit

so block123 is nested inside MECHD-Bigblock

 

MECHD-Bigblock

            └ Block123

 

everything in layer 1 of MECHD-Bigblock will change to color 1

but everything in the nested Block123 wont change color

 

Edited August 3, 2023 by mhupp

[CAD_Noob]

7 minutes ago, mhupp said:

That should get all blocks even if they are nested. but if the nested blocks don't have those strings in their name it won't change color.

 

I have the fixblock.lsp that I got from somewhere.. it's working fine though it only changes the parent block only. I still need to edit nested blocks and run fixblock.lsp on them..

 

And it's not working on multiple selection... 

 

but still your code works.. thanks!

 

Edited August 3, 2023 by CAD_Noob

[AKS]

On 8/3/2023 at 6:29 AM, CAD_Noob said:

 

I have the fixblock.lsp that I got from somewhere.. it's working fine though it only changes the parent block only. I still need to edit nested blocks and run fixblock.lsp on them..

 

And it's not working on multiple selection... 

 

but still your code works.. thanks!

 

Hello;

is there an updated code to change the color of block and all blocks inside it?

 

Thanks

 

[AKS]

@CAD_Noob do you have updated the code to include the nested blocks?