Lisp colour change for all layers and blocks

[maksolino]

Hello

1. colorfl is very nice lisp but I would like to have

the possibility to select more entities at once

2. colorx it's also nice but for me it will be better

whith the possibility to select the entities for changing the colour (not all)

Thanks

[maksolino]

Hello

1. colorfl is very nice lisp but I would like to have

the possibility to select more entities at once

2. colorx it's also nice but for me it will be better

whith the possibility to select the entities for changing the colour (not all)

Thanks

[VVA]

Hello

1. colorfl is very nice lisp but I would like to have

the possibility to select more entities at once

Look this version

2. colorx it's also nice but for me it will be better

whith the possibility to select the entities for changing the colour (not all)

Thanks

Try It

(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))
;;;get from  Alaspher  http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
[color="Red"](vl-load-com)[/color]
(defun pl:block-ent-color (/ adoc blocks color ent lays)
   (setq adoc  (vla-get-activedocument (vlax-get-acad-object))
         lays  (vla-get-layers adoc)
         color (acad_colordlg 256)
   )
   (if color
       (progn (setvar "errno" 0)
              (vla-startundomark adoc)
              (while (and (not (vl-catch-all-error-p
                                   (setq ent (vl-catch-all-apply
                                                 (function nentsel)
                                                 '("\nSelect entity <Exit>:")
                                             )
                                   )
                               )
                          )
                          (/= 52 (getvar "errno"))
                     )
                  (if ent
                      (progn (setq ent (vlax-ename->vla-object (car ent))
                                   lay (vla-item lays (vla-get-layer ent))
                             )
                             (if (= (vla-get-lock lay) :vlax-true)
                                 (progn (setq layloc (cons lay layloc))
                                        (vla-put-lock lay :vlax-false)
                                 )
                             )
                             (vl-catch-all-apply (function vla-put-color) (list ent color))
                             (vla-regen adoc acallviewports)
                      )
                      (princ "\nNothing selection! Try again.")
                  )
              )
              (foreach i layloc (vla-put-lock i :vlax-true))
              (vla-endundomark adoc)
       )
   )
   (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
   (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
         blocks (vla-get-blocks adoc)
         lays   (vla-get-layers adoc)
         color  (acad_colordlg 256)
   )
   (if color
       (progn (setvar "errno" 0)
              (vla-startundomark adoc)
              (while (and (not (vl-catch-all-error-p
                                   (setq ins (vl-catch-all-apply
                                                 (function entsel)
                                                 '("\nSelect block <Exit>:")
                                             )
                                   )
                               )
                          )
                          (/= 52 (getvar "errno"))
                     )
                  (if ins
                      (progn (setq ins (vlax-ename->vla-object (car ins)))
                             (if (= (vla-get-objectname ins) "AcDbBlockReference")
                                 (if (vlax-property-available-p ins 'path)
                                     (princ "\nThis is external reference! Try pick other.")
                                     (progn (_pl:block-color blocks ins color lays)
                                            (vla-regen adoc acallviewports)
                                     )
                                 )
                                 (princ "\nThis isn't block! Try pick other.")
                             )
                      )
                      (princ "\nNothing selection! Try again.")
                  )
              )
              (vla-endundomark adoc)
       )
   )
   (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
   (vlax-for e (vla-item blocks (vla-get-name ins))
       (setq lay (vla-item lays (vla-get-layer e)))
       (if (= (vla-get-freeze lay) :vlax-true)
           (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
       )
       (if (= (vla-get-lock lay) :vlax-true)
           (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
       )
       (vl-catch-all-apply (function vla-put-color) (list e color))
       (if (and (= (vla-get-objectname e) "AcDbBlockReference")
                (not (vlax-property-available-p e 'path))
           )
           (_pl:block-color blocks e color lays)
       )
       (foreach i layfrz (vla-put-freeze i :vlax-true))
       (foreach i layloc (vla-put-lock i :vlax-true))
   )
)

(progn
(princ "\BLCC - Changes color of the chosen blocks")
(princ "\nENCC - Changes color of the chosen objects (may be  element of the block)")
(princ))

[rayg11757]

I am not sure if I should post here or start a new thread. The posts here are cool and on track for what I am looking to do. The “encc” routine by VVA is awesome and very close to what I am looking to do.

BACKGROUND: I have blocks that contain multiple attributes. The attributes are on different layers so that they may be turned on and off independently from each other. The attribute color is defined and fixed within the block, so that the text line weight will be correct at plotting time. The lines for all objects are drawn on layer “0” so that the objects can take on the color properties of the layer where the block is placed. This permits the text lineweight to be independent from the objects lineweights during plotting.

THE PROBLEM: In some instances, the blocks describe new work, where the object lines are printed very heavy, and the text prints a medium-weight black. In other instances, the blocks describe existing work, and I move them to a layer that prints gray. However, the attribute text continues retain the original color and to print black. I desire to change the text color to a different shade of gray so that the text plots lighter.

THE SOLUTION: Ideally I would like to select multiple blocks and override the color of all text attributes within those block simultaneously, without changing the block definition. I would like the blocks that are not selected to remain unchanged.

Is anyone aware of any lisp code to accomplish these attribute text color changes?

Thank you for your help.

Ray

PS Unfortunately, I am still using 2006.

[Lee Mac]

Hi Ray,

 

Give this a shot mate, apologies for slow selection process, but a blanket change may require altering the block definition - will see what I can do.

 

(defun c:attcol (/ col ent obj)
 (vl-load-com)

 (if (setq col (acad_colordlg 256))

   (while
     (progn
       (setq ent (car (nentsel "\nSelect Attribute to Change: ")))

       (cond (  (eq 'ENAME (type ent))

                (if (eq "AcDbAttribute"
                        (vla-get-ObjectName
                          (setq obj (vlax-ename->vla-object ent))))
                  
                  (not (vla-put-color obj col)) t))))))
 (princ))

[Lee Mac]

Actually, try this:

 

(defun c:attcol2 (/ i col ss ent elst)

 (if (and (setq i -1 col (acad_colordlg 256))
          (setq ss  (ssget "_:L" '((0 . "INSERT") (66 . 1)))))
   
   (while (setq ent (ssname ss (setq i (1+ i))))

     (while (/= "SEQEND" (cdr (assoc 0 (setq elst (entget (setq ent (entnext ent)))))))

       (entmod          
         (if (assoc 62 elst)            
           (subst (cons 62 col) (assoc 62 elst) elst)            
           (append elst (list (cons 62 col))))))))
 
 (princ))

[Lee Mac]

Actually, this may suit you better

 

(defun c:attcol3 (/ unique dcl_write Set_Img

                   CATT DCTAG DLST ENT FNAME I ITM OBJ OLST PTR SS)

 ;; By Lee McDonnell (Lee Mac)  ~  28.12.2009
 (vl-load-com)

 (setq fname "LMAC_ATTCOL_V1.0.dcl")  
 (or *attcol* (setq *attcol* 1)) ;; Default Colour
 
 (defun unique (lst / result)
   (reverse
     (while (setq itm (car lst))
       (setq lst (vl-remove itm lst)
             result (cons itm result)))))

 (defun dcl_write (fname / wPath ofile)

   (if (not (findfile fname))

     (if (setq wPath (findfile "ACAD.PAT"))
       (progn
         (setq wPath (vl-filename-directory wPath))
         
         (or (eq "\\" (substr wPath (strlen wPath)))
             (setq wPath (strcat wPath "\\")))

         (setq ofile (open (strcat wPath fname) "w"))

         (foreach str

           '("attcol : dialog { label = \"Attribute Colour\";"
             "  : text { alignment = right; label = \"Lee McDonnell 2009\"; }"
             "  : list_box { label = \"Select Tags\"; key = \"tags\"; fixed_width = false;"
             "               multiple_select = true ; alignment = centered; }"
             "  : boxed_column { label = \"Colour\";"
             "    : row { spacer;"
             "      : button { key = \"cbut\"; width = 12; fixed_width = true; label = \"Select Colour\"; }"
             "      : image_button { key = \"cimg\"; alignment = centered; height = 1.5; width = 4.0;"
             "                       fixed_width = true; fixed_height = true; color = 2; }"
             "      spacer;"
             "    }"
             "    spacer;"
             "  }"
             "  spacer;"
             "  ok_cancel;"
             "}")

          (write-line str ofile))
         
       (close ofile)
         
       t)  ; File written successfully
       
   nil) ; Filepath not Found
     
 t)) ; DCL file already exists
 

 (defun Set_Img (key col)
   (start_image key)
   (fill_image 0 0 (dimx_tile key) (dimy_tile key) col)
   (end_image))
 

 (if (and (dcl_write fname)
          (setq i -1 ss (ssget "_:L" '((0 . "INSERT") (66 . 1)))))
   (progn
     
     (while (setq ent (ssname ss (setq i (1+ i))))

       (foreach att (append
                      (vlax-safearray->list
                        (vlax-variant-value
                          (vla-getAttributes
                            (setq obj (vlax-ename->vla-object ent)))))

                      (cond (  (vl-catch-all-error-p
                                 (setq cAtt
                                   (vl-catch-all-apply
                                     (function vlax-safearray->list)
                                       (list
                                         (vlax-variant-value
                                           (vla-getConstantAttributes obj)))))) nil)
                            (cAtt)))

         (setq oLst (cons (cons (vla-get-TagString att) att) oLst))))

     (cond (  (<= (setq dcTag (load_dialog fname)) 0)

              (princ "\n** Dialog File could not be Found **"))

           (  (not (new_dialog "attcol" dcTag))

              (princ "\n** Dialog Could not be Loaded **"))

           (t
              (start_list "tags")

              (mapcar (function add_list)
                      (setq dLst
                        (acad_strlsort
                          (Unique
                            (mapcar (function car) oLst)))))
              (end_list)
            
              (setq ptr (set_tile "tags" "0"))
              (Set_Img "cimg" *attcol*)

              (action_tile "cimg"
                (vl-prin1-to-string
                  (quote
                    (progn
                      (Set_Img "cimg"
                        (setq *attcol* (cond ((acad_colordlg *attcol*)) (*attcol*))))))))

              (action_tile "cbut"
                (vl-prin1-to-string
                  (quote
                    (progn
                      (Set_Img "cimg"
                        (setq *attcol* (cond ((acad_colordlg *attcol*)) (*attcol*))))))))

              (action_tile "tags"   "(setq ptr $value)")
              (action_tile "accept" "(done_dialog)")
              (action_tile "cancel" "(setq ptr nil) (done_dialog)")

              (start_dialog)
              (unload_dialog dcTag)

              (if ptr
                (progn
                  (setq ptr
                    (mapcar
                      (function
                        (lambda (x) (nth x dLst))) (read (strcat "(" ptr ")"))))

                  (mapcar
                    (function
                      (lambda (x)
                        (and (vl-position (car x) ptr)
                             (vla-put-color (cdr x) *attcol*)))) oLst))

                (princ "\n*Cancel*"))))))
 (princ))

[rayg11757]

Lee Mac,

 

Awesome... Thank you !!!

 

Attcol2 is exactly what I need. Attcol1 provides good manual control and will be useful, but Attcol3 provides so much flexiblity and the ability to select any number of attributes independently is incredible.

 

Thanks again for your help.

 

Ray

[Lee Mac]

You're welcome Ray - I had fun with it

[saiden_ea]

hi,

 

i need to download a lisp file; colorx, colorxref, colorxl & colorxrefl...

 

tnx...

[ichlove]

This lisp can only select one block every time, is that possible to have select area?and each area can change the color you want?

 

Thanks

Look this version

 

Try It

(defun c:blcc () (pl:block-color) (princ))
(defun c:encc () (pl:block-ent-color) (princ))
;;;get from  Alaspher  http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun pl:block-ent-color (/ adoc blocks color ent lays)
   (setq adoc  (vla-get-activedocument (vlax-get-acad-object))
         lays  (vla-get-layers adoc)
         color (acad_colordlg 256)
   )
   (if color
       (progn (setvar "errno" 0)
              (vla-startundomark adoc)
              (while (and (not (vl-catch-all-error-p
                                   (setq ent (vl-catch-all-apply
                                                 (function nentsel)
                                                 '("\nSelect entity <Exit>:")
                                             )
                                   )
                               )
                          )
                          (/= 52 (getvar "errno"))
                     )
                  (if ent
                      (progn (setq ent (vlax-ename->vla-object (car ent))
                                   lay (vla-item lays (vla-get-layer ent))
                             )
                             (if (= (vla-get-lock lay) :vlax-true)
                                 (progn (setq layloc (cons lay layloc))
                                        (vla-put-lock lay :vlax-false)
                                 )
                             )
                             (vl-catch-all-apply (function vla-put-color) (list ent color))
                             (vla-regen adoc acallviewports)
                      )
                      (princ "\nNothing selection! Try again.")
                  )
              )
              (foreach i layloc (vla-put-lock i :vlax-true))
              (vla-endundomark adoc)
       )
   )
   (princ)
)

(defun pl:block-color (/ adoc blocks color ins lays)
   (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
         blocks (vla-get-blocks adoc)
         lays   (vla-get-layers adoc)
         color  (acad_colordlg 256)
   )
   (if color
       (progn (setvar "errno" 0)
              (vla-startundomark adoc)
              (while (and (not (vl-catch-all-error-p
                                   (setq ins (vl-catch-all-apply
                                                 (function entsel)
                                                 '("\nSelect block <Exit>:")
                                             )
                                   )
                               )
                          )
                          (/= 52 (getvar "errno"))
                     )
                  (if ins
                      (progn (setq ins (vlax-ename->vla-object (car ins)))
                             (if (= (vla-get-objectname ins) "AcDbBlockReference")
                                 (if (vlax-property-available-p ins 'path)
                                     (princ "\nThis is external reference! Try pick other.")
                                     (progn (_pl:block-color blocks ins color lays)
                                            (vla-regen adoc acallviewports)
                                     )
                                 )
                                 (princ "\nThis isn't block! Try pick other.")
                             )
                      )
                      (princ "\nNothing selection! Try again.")
                  )
              )
              (vla-endundomark adoc)
       )
   )
   (princ)
)

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
   (vlax-for e (vla-item blocks (vla-get-name ins))
       (setq lay (vla-item lays (vla-get-layer e)))
       (if (= (vla-get-freeze lay) :vlax-true)
           (progn (setq layfrz (cons lay layfrz)) (vla-put-freeze lay :vlax-false))
       )
       (if (= (vla-get-lock lay) :vlax-true)
           (progn (setq layloc (cons lay layloc)) (vla-put-lock lay :vlax-false))
       )
       (vl-catch-all-apply (function vla-put-color) (list e color))
       (if (and (= (vla-get-objectname e) "AcDbBlockReference")
                (not (vlax-property-available-p e 'path))
           )
           (_pl:block-color blocks e color lays)
       )
       (foreach i layfrz (vla-put-freeze i :vlax-true))
       (foreach i layloc (vla-put-lock i :vlax-true))
   )
)

(progn
(princ "\BLCC - Changes color of the chosen blocks")
(princ "\nENCC - Changes color of the chosen objects (may be  element of the block)")
(princ))

[VVA]

This lisp can only select one block every time, is that possible to have select area?and each area can change the color you want?

Try it

(defun c:blccA ()
;;;blccA - BLock Change Color Area
 (pl:block-colorA)
 (princ)
) ;_ end of defun
;;;get from  Alaspher  http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun pl:block-colorA (/ adoc blocks color ins lays ss lst)
 (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
       blocks (vla-get-blocks adoc)
       lays   (vla-get-layers adoc)
 ) ;_ end of setq
 (if (and (setq color (acad_colordlg 256))
          (setq ss (ssget '((0 . "INSERT"))))
          (progn
            (repeat (setq ins (sslength ss)) ;_ end setq
              (setq lst (cons (ssname ss (setq ins (1- ins))) lst))
            ) ;_ end repeat
            lst
          ) ;_ end of progn
     ) ;_ end of and
   (progn
     (vla-startundomark adoc)
     (foreach ins lst
       (setq ins (vlax-ename->vla-object ins))
       (if (= (vla-get-objectname ins) "AcDbBlockReference")
         (if (vlax-property-available-p ins 'path)
           (princ "\nThis is external reference! Skip.")
           (_pl:block-color blocks ins color lays)
         ) ;_ end of if
         (princ "\nThis isn't block! Try pick other.")
       ) ;_ end of if
     ) ;_ end of repeat
     (vla-regen adoc acallviewports)
     (vla-endundomark adoc)
   ) ;_ end of progn
 ) ;_ end of if
 (princ)
) ;_ end of defun

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
 (vlax-for e (vla-item blocks (vla-get-name ins))
   (setq lay (vla-item lays (vla-get-layer e)))
   (if (= (vla-get-freeze lay) :vlax-true)
     (progn (setq layfrz (cons lay layfrz))
            (vla-put-freeze lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (if (= (vla-get-lock lay) :vlax-true)
     (progn (setq layloc (cons lay layloc))
            (vla-put-lock lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (vl-catch-all-apply (function vla-put-color) (list e color))
   (if (and (= (vla-get-objectname e) "AcDbBlockReference")
            (not (vlax-property-available-p e 'path))
       ) ;_ end of and
     (_pl:block-color blocks e color lays)
   ) ;_ end of if
   (foreach i layfrz (vla-put-freeze i :vlax-true))
   (foreach i layloc (vla-put-lock i :vlax-true))
 ) ;_ end of vlax-for
) ;_ end of defun

(progn
 (princ
   "\BLCCA - Changes in the color of selected blocks in the area"
 ) ;_ end of princ
 (princ)
) ;_ end of progn

[ichlove]

Thanks,VVA!

 

Is that possible the select area also includes none-block objects and multileader?

 

 

 

Try it

(defun c:blccA ()
;;;blccA - BLock Change Color Area
 (pl:block-colorA)
 (princ)
) ;_ end of defun
;;;get from  Alaspher  http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun pl:block-colorA (/ adoc blocks color ins lays ss lst)
 (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
       blocks (vla-get-blocks adoc)
       lays   (vla-get-layers adoc)
 ) ;_ end of setq
 (if (and (setq color (acad_colordlg 256))
          (setq ss (ssget '((0 . "INSERT"))))
          (progn
            (repeat (setq ins (sslength ss)) ;_ end setq
              (setq lst (cons (ssname ss (setq ins (1- ins))) lst))
            ) ;_ end repeat
            lst
          ) ;_ end of progn
     ) ;_ end of and
   (progn
     (vla-startundomark adoc)
     (foreach ins lst
       (setq ins (vlax-ename->vla-object ins))
       (if (= (vla-get-objectname ins) "AcDbBlockReference")
         (if (vlax-property-available-p ins 'path)
           (princ "\nThis is external reference! Skip.")
           (_pl:block-color blocks ins color lays)
         ) ;_ end of if
         (princ "\nThis isn't block! Try pick other.")
       ) ;_ end of if
     ) ;_ end of repeat
     (vla-regen adoc acallviewports)
     (vla-endundomark adoc)
   ) ;_ end of progn
 ) ;_ end of if
 (princ)
) ;_ end of defun

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
 (vlax-for e (vla-item blocks (vla-get-name ins))
   (setq lay (vla-item lays (vla-get-layer e)))
   (if (= (vla-get-freeze lay) :vlax-true)
     (progn (setq layfrz (cons lay layfrz))
            (vla-put-freeze lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (if (= (vla-get-lock lay) :vlax-true)
     (progn (setq layloc (cons lay layloc))
            (vla-put-lock lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (vl-catch-all-apply (function vla-put-color) (list e color))
   (if (and (= (vla-get-objectname e) "AcDbBlockReference")
            (not (vlax-property-available-p e 'path))
       ) ;_ end of and
     (_pl:block-color blocks e color lays)
   ) ;_ end of if
   (foreach i layfrz (vla-put-freeze i :vlax-true))
   (foreach i layloc (vla-put-lock i :vlax-true))
 ) ;_ end of vlax-for
) ;_ end of defun

(progn
 (princ
   "\BLCCA - Changes in the color of selected blocks in the area"
 ) ;_ end of princ
 (princ)
) ;_ end of progn

[VVA]

Thanks,VVA!

Is that possible the select area also includes none-block objects and multileader?

Try it

(defun c:colorA (/ adoc blocks color ins lays ss lst *error*)
;;; Color Area - - Changes in the color of selected items in the area
;;;http://www.cadtutor.net/forum/showthread.php?t=533&page=8
;;;get from  Alaspher  http://forum.dwg.ru/showthread.php?t=1036
;;; http://forum.dwg.ru/showpost.php?p=166220&postcount=18
(defun *error* (msg)(bg:layer-status-restore)(princ msg)(princ))
 (setq adoc   (vla-get-activedocument (vlax-get-acad-object))
       blocks (vla-get-blocks adoc)
       lays   (vla-get-layers adoc)
 ) ;_ end of setq
 (if (and (setq color (acad_colordlg 256))
          (setq ss (ssget))
          (progn
            (repeat (setq ins (sslength ss)) ;_ end setq
              (setq lst (cons (ssname ss (setq ins (1- ins))) lst))
            ) ;_ end repeat
            lst
          ) ;_ end of progn
     ) ;_ end of and
   (progn
     (vla-startundomark adoc)
     (bg:layer-status-save)
     (foreach ins lst
       (setq ins (vlax-ename->vla-object ins))
       (if (= (vla-get-objectname ins) "AcDbBlockReference")
         (if (vlax-property-available-p ins 'path)
           (princ "\nThis is external reference! Skip.")
           (progn
             (_pl:block-color blocks ins color lays)
             (Change-Object-Color ins color)
           )
         ) ;_ end of if
         (Change-Object-Color ins color)
       ) ;_ end of if
       
     ) ;_ end of repeat
     (vla-regen adoc acallviewports)
     (bg:layer-status-restore)
     (vla-endundomark adoc)
   ) ;_ end of progn
 ) ;_ end of if
 (princ)
) ;_ end of defun

(defun _pl:block-color (blocks ins color lays / lay layfrz layloc)
 (vlax-for e (vla-item blocks (vla-get-name ins))
   (setq lay (vla-item lays (vla-get-layer e)))
   (if (= (vla-get-freeze lay) :vlax-true)
     (progn (setq layfrz (cons lay layfrz))
            (vla-put-freeze lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (if (= (vla-get-lock lay) :vlax-true)
     (progn (setq layloc (cons lay layloc))
            (vla-put-lock lay :vlax-false)
     ) ;_ end of progn
   ) ;_ end of if
   (vl-catch-all-apply (function vla-put-color) (list e color))
   (if (and (= (vla-get-objectname e) "AcDbBlockReference")
            (not (vlax-property-available-p e 'path))
       ) ;_ end of and
     (_pl:block-color blocks e color lays)
   ) ;_ end of if
   (foreach i layfrz (vla-put-freeze i :vlax-true))
   (foreach i layloc (vla-put-lock i :vlax-true))
 ) ;_ end of vlax-for
) ;_ end of defun
(defun Change-Object-Color (Obj Color  / txtstr tmp txt)
;;;========================================================================
;;;_color object start
(if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'Color)
    ) ;_ end of and
  (vla-put-Color Obj Color)
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'TextString)
    ) ;_ end of and
  (progn
    (setq txtstr
	   (if (vlax-method-applicable-p Obj 'FieldCode)
	       (vla-FieldCode Obj)
	       (vlax-get-property Obj 'TextString))
	  )
    (setq tmp 0)
    (while (setq tmp (VL-STRING-SEARCH "\\C" txtstr tmp))
      (setq txtstr
      (vl-string-subst
	(strcat (substr txtstr (1+ tmp) 2)(itoa Color) ";")
	(substr txtstr (1+ tmp) (- (1+ (VL-STRING-SEARCH ";" txtstr tmp)) tmp))
	txtstr
	tmp)
	    )
      (setq tmp (+ tmp 3))
      )
    (vla-put-Textstring Obj txtstr)
    )
) ;_ end of if
(if (and (vlax-write-enabled-p Obj)
	 (= (vla-get-ObjectName obj) "AcDbBlockReference")
	 (= (vla-get-HasAttributes obj) :vlax-true)
    ) ;_ end of and
  (foreach att (vlax-safearray->list
		 (vlax-variant-value (vla-GetAttributes obj))
	       ) ;_ end of vlax-safearray->list
    (if	(and (vlax-write-enabled-p att)
	     (vlax-property-available-p att 'Color)
	) ;_ end of and
      (vla-put-Color att Color)
    ) ;_ end of if
  ) ;_ end of foreach
) ;_ end of if
       (if (and (vlax-write-enabled-p Obj)
	  (wcmatch (vla-get-Objectname Obj)  "*Dimension*,AcDb*Leader")
     ) ;_ end of and
   (progn
     (vl-catch-all-apply 'vla-put-ExtensionLineColor (list Obj acByBlock)) ;_Color
     (vl-catch-all-apply 'vla-put-TextColor (list Obj acByBlock)) ;_Color
     (vl-catch-all-apply 'vla-put-DimensionLineColor (list Obj acByBlock));_Color
     (if (vlax-property-available-p Obj 'LeaderLineColor)
       (progn
	 (setq tmp (vla-getinterfaceobject(vlax-get-acad-object)(strcat "AutoCAD.AcCmColor."
	(substr (getvar "ACADVER") 1 2))))
	 (vla-put-colorindex  tmp  acByBlock) ;_Color
	 (vl-catch-all-apply 'vla-put-LeaderLineColor (list Obj tmp))
	 )
       )
            (if (and (vlax-write-enabled-p Obj)
	 (vlax-property-available-p Obj 'TextString)
                ) ;_ end of and
               (progn
                 (setq txtstr
	   (if (vlax-method-applicable-p Obj 'FieldCode)
	       (vla-FieldCode Obj)
	       (vlax-get-property Obj 'TextString))
	  )
                 (setq txtstr
                 ((lambda (mtext / text str)
                    (setq Text "")
                    (while (/= Mtext "")
                      (cond
                        ((wcmatch(strcase (setq Str (substr Mtext 1 3)))"{\\C") ;_ end of wcmatch
                         (setq Mtext(substr Mtext (+ 2 (vl-string-search ";" Mtext)))) ;_ end of setq
                        )
                        ((wcmatch(strcase (setq Str (substr Mtext 1 2)))"\\C")
                          (setq Mtext(substr Mtext (+ 2 (vl-string-search ";" Mtext))))
                        )
                        ((wcmatch(strcase (setq Str (substr Mtext 1 2))) "\\[{}]")
                          (setq Text  (strcat Text (substr Mtext 1 2))
                               Mtext (substr Mtext 3)
                         ) ;_ end of setq
                        )
                        ((wcmatch (substr Mtext 1 1) "[{}]")
                         (setq Mtext (substr Mtext 2))
                        )
                        (t
                         (setq Text  (strcat Text (substr Mtext 1 1))
                               Mtext (substr Mtext 2)
                         ) ;_ end of setq
                        )
                      ) ;_ end of cond
                    ) ;_ end of while
                   text
                  ) ;_lambda
                   txtstr
                 )
                       )
                 (vlax-put-property Obj 'TextString (strcat "{\\C" (itoa color) ";" txtstr "}"))
               );_progn
              )
            
   ) ;_ end of progn
 ) ;_ end of if
;;;_color object end
;;;========================================================================
) ;_ end of defun
(defun bg:layer-status-restore ()
   (foreach item *BG_LAYER_LST*
     (if (not (vlax-erased-p (car item)))
       (vl-catch-all-apply
         '(lambda ()
            (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
            (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
            ) ;_ end of lambda
         ) ;_ end of vl-catch-all-apply
       ) ;_ end of if
     ) ;_ end of foreach
   (setq *BG_LAYER_LST* nil)
   ) ;_ end of defun

 (defun bg:layer-status-save ()
   (setq *BG_LAYER_LST* nil)
   (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
     (setq *BG_LAYER_LST* (cons (list item
                                 (cons "freeze" (vla-get-freeze item))
                                 (cons "lock" (vla-get-lock item))
                                 ) ;_ end of cons
                           *BG_LAYER_LST*
                           ) ;_ end of cons
           ) ;_ end of setq
     (vla-put-lock item :vlax-false)
     (if (= (vla-get-freeze item) :vlax-true)
     (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
     ) ;_ end of vlax-for
   ) ;_ end of defun
(progn
 (princ
   "\ColorA - Changes in the color of selected items in the area"
 ) ;_ end of princ
 (princ)
) ;_ end of progn

Edited January 11, 2011 by VVA

[michaelriver23]

VVA-

 

I have used colorxref, this is exactly what i need. but . . .

 

I work for an MEP firm, we receive dwg's from architects in full color, but usually have to go through some process of either binding down all the xref'd dwg then bursting and erasing and changing layer color to get it down to one solid background.

 

the current project we have which is going to go on for the next 4 years and comes from and archiecture firm that is infamous for weekly drawing changes.

 

I need something that allows me to change the colors all the way down through nested xref and inlcuding block changes, but changes the colors by layer. Also it is ok if it changes the xref'd files. I just need something automatic, I like the result of colorxref, but i can't save with that.

 

thanks

[bograd]

Hello,

 

Is there a way to select an object (which usually contains severals blocks with different layers) and select a color for the final block?

To achieve this i need to explode the block several time and then change the color. Can this be done just by selecting the block and the color?

 

To put it simple, i need exactly the same ColorX lsp posted on the first page of the thread, but to apply only to the objects i select.

[bograd]

I found a solution.

I used norm.lsp found in other thread, and afetr that i can change the color to any block i need.

[VVA]

I found a solution.

I used norm.lsp found in other thread, and afetr that i can change the color to any block i need.

This is the best solution. Another variant:

BLCC - Changes color of the chosen blocks

ENCC - Changes color of the chosen objects (may be element of the block)

 

>michaelriver23 I need more time to see what can I do

[bograd]

I get an error: "; error: no function definition: VLAX-GET-ACAD-OBJECT"

I use AutoCAD 2002 bay the way.

[VVA]

I get an error: "; error: no function definition: VLAX-GET-ACAD-OBJECT"

I use AutoCAD 2002 bay the way.

This will help you

PS I corrected the code for the link in previous post