Color to Layer Routine

[DPB]

I know this routine has been discussed to death but I have a new twist and was wondering if anyone has a routine that can do the following;

The routine will need to select every entity in a drawing, including entities within blocks, of a specific color and place it on a given layer. The routine will need to go through every color number in AutoCAD automatically and place the color designated on the layer specfied within the routine. Once that has been completed all text and mtext will need to be selected and placed on a given layer.

My lisp ability is a little weak, but here's my attempt at it, see attached lisp file. I hope someone can help me fine tune it so it works properly.

Thanks,
Dan

[Adesu]

Hi daniel,
this code not yet test


(defun c:ccx (/ cn en lay lst n ss1 sst ssx txt)
(setq cn 1)
(setq ss1 nil)
(command "-layer" "s" "0" "")
(setvar "cmdecho" 0)
(prompt "RUNNING...")
(setq lst '("G-DETL-WT_1" "G-DETL-WT_2" "G-DETL-WT_3" "G-DETL-WT_4" "G-DETL-SCRN-50_1"
"G-DETL-SCRN-50_2" "G-DETL-SCRN-50_3" "G-DETL-SCRN-50_4" "G-DETL-SCRN-75_0"
"G-DETL-SCRN-75_1" "G-DETL-SCRN-75_2" "G-DETL-SCRN-75_3" "G-DETL-SCRN-75_4"))
(foreach x lst
(setq ssx (ssget "_x" (list (cons 8 x))))
(command "change" ssx "" "p" "la" x "c" "bylayer" "")
) ; foreach
(setq sst (ssget "x" (list (cons 0 "TEXT"))))
(setq n (1- (sslength sst)))
(while
(>= n 0)
(setq txt (entget (ssname sst n))
en (dxf -1 txt))
(command "change" en "" "p" "la" "G-DETL-TXN1" "c" "bylayer" "")
(setq n (1- n))
) ; while
(setq sst (ssget "x" (list (cons 0 "MTEXT")))
n (1- (sslength sst)))
(while
(>= n 0)
(setq txt (entget (ssname sst n))
en (dxf -1 txt))
(command "change" en "" "p" "la" "G-DETL-TXN1" "c" "bylayer" "")
(setq n (1- n))
) ; while
(setvar "cmdecho" 1)
(princ)
)



I know this routine has been discussed to death but I have a new twist and was wondering if anyone has a routine that can do the following;

The routine will need to select every entity in a drawing, including entities within blocks, of a specific color and place it on a given layer. The routine will need to go through every color number in AutoCAD automatically and place the color designated on the layer specfied within the routine. Once that has been completed all text and mtext will need to be selected and placed on a given layer.

My lisp ability is a little weak, but here's my attempt at it, see attached lisp file. I hope someone can help me fine tune it so it works properly.

Thanks,
Dan

[kpblc2000]

Another version:

(defun ccx (/ adoc *error* ar lin pol cn lw fun_conv-pickset-to-list ss1)

(defun *error* (msg)
(vla-endundomark adoc)
(princ msg)
(princ)
) ;_ end of defun

(defun fun_conv-pickset-to-list (ss / count lst)
(if ss
(progn
(setq count -1)
(repeat (sslength ss)
(setq lst (cons (ssname ss (setq count (1+ count))) lst))
) ;_ end of repeat
lst
) ;_ end of progn
) ;_ end of if
) ;_ end of defun

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

(setq cn 1)
(prompt "RUNNING...")
(repeat 236
(setq lnm (cond
((member cn '(2 3 10 11 35 37 81 111)) "G-DETL-WT_2")
((member cn '(33 43)) "G-DETL-WT_0")
((member cn '(4 12 17 30 140)) "G-DETL-WT_3")
((member cn '(7 13 164 16 5 51)) "G-DETL-WT_4")
((member cn '(45 55)) "G-DETL-SCRN-75_0")
((member cn '(8 15 18 20 31)) "G-DETL-SCRN-75_1")
((member cn '(50 90)) "G-DETL-SCRN-75_2")
((member cn '(32 42)) "G-DETL-SCRN-75_3")
((member cn '(160 170 56)) "G-DETL-SCRN-75_4")
((member cn '(23 210 220)) "G-DETL-SCRN-50_1")
((member cn '(47 83)) "G-DETL-SCRN-50_2")
((member cn '(130 141)) "G-DETL-SCRN-50_3")
((member cn '(230 240 53)) "G-DETL-SCRN-50_4")
(t "G-DETL-WT_1")
) ;_ end of cond
ss1 (ssget "_X" (list (cons 62 cn)))
cn (1+ cn)
) ;_ end of setq
(if (not (tblobjname "layer" lnm))
(vla-add (vla-get-layers adoc) lnm)
) ;_ end of if
(foreach item
(mapcar 'vlax-ename->vla-object (fun_conv-pickset-to-list ss1))
(vl-catch-all-apply
'(lambda ()
(vla-put-layer item lnm)
(vla-put-color item 256)
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of foreach
) ;_ end of repeat
(if (not (tblobjname "layer" "G-DETL-TXN1"))
(vla-add (vla-get-layers adoc) "G-DETL-TXN1")
) ;_ end of if
(foreach item (mapcar
'vlax-ename->vla-object
(fun_conv-pickset-to-list (ssget "_X" '((0 . "TEXT,MTEXT"))))
) ;_ end of mapcar
(vl-catch-all-apply
'(lambda ()
(vla-put-layer item "G-DETL-TXN1")
(vla-put-color item 256)
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of foreach
(vla-endundomark adoc)
(princ)
) ;_ end of defun

[DPB]

Thanks for the assistance from both of you, I'll load the routines and give it a try!!

Regards,
Dan

[peter]

Here is my version.

Regards,

Peter