BibJim2112 发表于 2022-7-5 17:37:35

Change Layer-Keep original pro

I am looking for a LISP routine that will change the layer of multiple objects yet have is so each object maintains the same properties(i.e. color, linetype) of the original layer.
 
Thanks BigJim2112
 
My name was suppose to be BigJim2112 not "Bib" but must have pressed the wrong button.:roll:

Tharwat 发表于 2022-7-5 17:45:34

Welcome to CADTutor.
 
Try this program;

(defun c:chglay(/ lay sel int) ;; Tharwat - date: 30.may.2016 ;; (cond   ((and (setq lay (getstring t "\nSpecify layer name:"))         (not (tblsearch "LAYER" lay)))    (alert (strcat "Layer nameis not found !")))   ((and (princ (strcat "\nSelect objects to move to layer:"))         (setq sel (ssget "_:L" '((0 . "~VIEWPORT")))))    (repeat (setq int (sslength sel))      (entmod (append (entget (ssname sel (setq int (1- int))))                      (list (cons 8 lay)'(62 . 256) '(6 . "ByLayer") '(370 . -1))))      )    )   ) (princ) )

BibJim2112 发表于 2022-7-5 17:51:01

Thanks Tharwat for the post.The routine changes the layers of the objects but the objects take on the color and linetype of the new layer.

BIGAL 发表于 2022-7-5 17:54:34

BibJim2112 you need a two step entmod read the colour and linetype of the object and reset the "bylayer" to the old colour, if (assoc 62 obj) returns nil then obj is by layer so you must then go and read the layer table to find its default color setting.
 

; not tested !!(repeat (setq int (sslength sel))(setq obj (ssname sel (setq int (1- int))))(setq col (assoc 62 obj)) ; need check here for by colour and look up layer table(setq lt (assoc 1 obj)) ; need check here for by layer and look up layer table      (entmod (append obj)                      (list (cons 62 Col))                      (list (cons 6 Lt))                      (list (cons 8 lay))      )

Tharwat 发表于 2022-7-5 18:00:10

 
 
I thought you did want them to change as described into your first post !
Anyway CODES UPDATED ABOVE.

Lee Mac 发表于 2022-7-5 18:00:53

Assuming I've correctly understood, please try the following:
(defun c:layerchange ( / enx idx itm lay lst new old sel )   (while (and (/= "" (setq new (getstring t "\nSpecify new layer: "))) (not (snvalid new)))       (princ "\nLayer name invalid.")   )   (if (and (/= "" new) (setq sel (ssget "_:L" '((0 . "~VIEWPORT")))))       (repeat (setq idx (sslength sel))         (setq enx (entget (ssname sel (setq idx (1- idx))))               old (assoc 8 enx)         )         (if (setq itm (cdr (assoc old lst)))               (setq enx (append enx itm))               (setq lay (entget (tblobjname "layer" (cdr old)))                     lst (cons (list old (assoc 62 lay) (assoc 6 lay) (assoc 370 lay)) lst)                     enx (append enx (cdar lst))               )         )         (entmod (subst (cons 8 new) old enx))       )   )   (princ))

guran 发表于 2022-7-5 18:09:15

Thank you Lee Mac. Very nice lisp to have if you want to move things to a hidden layer, but still want everything to look the same.

Lee Mac 发表于 2022-7-5 18:12:49

 
You're welcome - I'm glad you find it useful!

BibJim2112 发表于 2022-7-5 18:15:32

Thanks guys for the help on this!!!!Programs work amazing.   Lee Mac...not only has your program worked flawlessly but you have some cool stuff on your website.   I am just starting to learn LISP and your site was a HUGE help.If you ever get to Orlando Florida I will buy you a beer(assuming you are 21 of course).LOL

Lee Mac 发表于 2022-7-5 18:19:16

 
Many thanks Jim - I'm delighted that you find the program and my site so useful, and I'll certainly keep your offer in mind if ever I'm in Orlando!
页: [1] 2
查看完整版本: Change Layer-Keep original pro