Chmcdan211 Posted April 16, 2015 Share Posted April 16, 2015 All, I would like to know if anyone knows of a lisp that will do this. 1. Copy the layer of a selected object (4"-HG-BC38-9100) 2. Add a suffix to the end of that layer (-UG) 3. Move only the selected object to that new layer (4"-HG-BC38-9100-UG) I have made a lisp that will add a suffix to the selected layer, however I can't figure out how to keep all other objects on the original layer and move the selected object to a layer of the same name with a suffix. EX. objects are created on layer 4"-HG-BC38-9100 I want the lisp and select an object that is on that layer and have the lisp copy that layer, add a -UG suffix to it and move only the selected object to layer 4"-HG-BC38-9100-UG I think that makes sense... Chris Quote Link to comment Share on other sites More sharing options...
BIGAL Posted April 17, 2015 Share Posted April 17, 2015 There are different ways to do it, but using simple lisp ; simple version (defun C:test ( / obj layname suff) (setq obj (entsel)) (setq layname (cdr (assoc 8 (entget (car obj))))) (setq suff (getstring " Enter suffix")) (setq layname (strcat layname suff)) (command "-layer" "N" layname "") (command "CHPROP" obj "" "LA" layname "") ) (c:TEST) Quote Link to comment Share on other sites More sharing options...
enthralled Posted September 19, 2019 Share Posted September 19, 2019 (edited) On 4/17/2015 at 5:47 AM, BIGAL said: There are different ways to do it, but using simple lisp ; simple version (defun C:test ( / obj layname suff) (setq obj (entsel)) (setq layname (cdr (assoc 8 (entget (car obj))))) (setq suff (getstring " Enter suffix")) (setq layname (strcat layname suff)) (command "-layer" "N" layname "") (command "CHPROP" obj "" "LA" layname "") ) (c:TEST) Can this be made to work for a selection of multiple objects of different layers? Currently it only works for single object selection. Edit: It would be much helpful if the newly created layer (with the suffix) keeps the properties of the original layer (Color, line W and type...). As it is now it resets the layer properties. Edited September 19, 2019 by enthralled Retain layer properties Quote Link to comment Share on other sites More sharing options...
dlanorh Posted September 19, 2019 Share Posted September 19, 2019 1 hour ago, enthralled said: Can this be made to work for a selection of multiple objects of different layers? Currently it only works for single object selection. Edit: It would be much helpful if the newly created layer (with the suffix) keeps the properties of the original layer (Color, line W and type...). As it is now it resets the layer properties. The simple version above uses the layer of the selected object as the base for the new layer. How would this work if you are selecting multiple objects on multiple layers? Quote Link to comment Share on other sites More sharing options...
BIGAL Posted September 20, 2019 Share Posted September 20, 2019 Maybe change the 1 line (command "CHPROP" obj "" "LA" layname "") (command "CHPROP" (ssget) "" "LA" layname "") Quote Link to comment Share on other sites More sharing options...
pkenewell Posted October 2, 2019 Share Posted October 2, 2019 (edited) Try one of these 2 functions. The 1st one (TEST2) just renames the layers. The 2nd one (TEST3) creates new layers and moves the selection to the new layers (Note - Currently the color and linetypes of the original layers are not replicated in TEST3). (defun C:test2 ( / cnt el la llst nlst ss suff) (setq ss (ssget) cnt 0) (repeat (sslength ss) (setq el (entget (ssname ss cnt)) la (cdr (assoc 8 el)) cnt (1+ cnt) ) (if (not (member la llst))(setq llst (cons la llst))) ) (if (setq suff (getstring "\nEnter suffix for layers: ")) (progn (setq nlst (mapcar '(lambda (x) (strcat x "-" suff)) llst) cnt 0) (foreach i llst (command "._-rename" "_LA" i (nth cnt nlst)) (setq cnt (1+ cnt)) ) ) ) (princ) ) (defun C:test3 ( / cnt el en la llst nlst ss suff) (setq ss (ssget) cnt 0) (repeat (sslength ss) (setq el (entget (ssname ss cnt)) la (cdr (assoc 8 el)) cnt (1+ cnt) ) (if (not (member la llst))(setq llst (cons la llst))) ) (if (setq suff (getstring "\nEnter suffix for layers: ")) (progn (setq nlst (mapcar '(lambda (x) (strcat x "-" suff)) llst) cnt 0) (foreach i nlst (command "._-layer" "_N" i "") (setq cnt (1+ cnt)) ) (setq cnt 0) (repeat (sslength ss) (setq en (ssname ss cnt) el (entget en) la (cdr (assoc 8 el)) el (subst (cons 8 (strcat la "-" suff)) (assoc 8 el) el) cnt (1+ cnt) ) (entmod el) ) ) ) (princ) ) Edited October 2, 2019 by pkenewell 1 Quote Link to comment Share on other sites More sharing options...
enthralled Posted October 3, 2019 Share Posted October 3, 2019 To preserve original layer properties, I'm currently cutting the objects to a new dwg, rename the layers with required suffix, then cut and paste back into the original drawing. Quote Link to comment Share on other sites More sharing options...
pkenewell Posted October 3, 2019 Share Posted October 3, 2019 (edited) 10 hours ago, enthralled said: To preserve original layer properties, I'm currently cutting the objects to a new dwg, rename the layers with required suffix, then cut and paste back into the original drawing. Try this revision to my TEST3 command. It currently only reads the ACI color codes from the original layers, but could be updated to capture the other color codes (truecolor, colorbook) as well. Let me know if that is necessary. (defun C:test3 ( / cl cnt el en la llst lt nlst ol suff) (setq ss (ssget) cnt 0) (repeat (sslength ss) (setq el (entget (ssname ss cnt)) la (cdr (assoc 8 el)) cnt (1+ cnt) ) (if (not (member la llst))(setq llst (cons la llst))) ) (if (setq suff (getstring "\nEnter suffix for layers: ")) (progn (setq nlst (mapcar '(lambda (x) (strcat x "-" suff)) llst) cnt 0) (foreach i nlst (setq ol (tblsearch "LAYER" (nth 1 llst)) cl (cdr (assoc 62 ol)) lt (cdr (assoc 6 ol)) ) (command "._-layer" "_N" i "_c" cl i "_l" lt i "") (setq cnt (1+ cnt)) ) (setq cnt 0) (repeat (sslength ss) (setq en (ssname ss cnt) el (entget en) la (cdr (assoc 8 el)) el (subst (cons 8 (strcat la "-" suff)) (assoc 8 el) el) cnt (1+ cnt) ) (entmod el) ) ) ) (princ) ) Edited October 3, 2019 by pkenewell 1 Quote Link to comment Share on other sites More sharing options...
enthralled Posted May 7 Share Posted May 7 On 10/4/2019 at 12:20 AM, pkenewell said: Try this revision to my TEST3 command. It currently only reads the ACI color codes from the original layers, but could be updated to capture the other color codes (truecolor, colorbook) as well. Let me know if that is necessary. (defun C:test3 ( / cl cnt el en la llst lt nlst ol suff) (setq ss (ssget) cnt 0) (repeat (sslength ss) (setq el (entget (ssname ss cnt)) la (cdr (assoc 8 el)) cnt (1+ cnt) ) (if (not (member la llst))(setq llst (cons la llst))) ) (if (setq suff (getstring "\nEnter suffix for layers: ")) (progn (setq nlst (mapcar '(lambda (x) (strcat x "-" suff)) llst) cnt 0) (foreach i nlst (setq ol (tblsearch "LAYER" (nth 1 llst)) cl (cdr (assoc 62 ol)) lt (cdr (assoc 6 ol)) ) (command "._-layer" "_N" i "_c" cl i "_l" lt i "") (setq cnt (1+ cnt)) ) (setq cnt 0) (repeat (sslength ss) (setq en (ssname ss cnt) el (entget en) la (cdr (assoc 8 el)) el (subst (cons 8 (strcat la "-" suff)) (assoc 8 el) el) cnt (1+ cnt) ) (entmod el) ) ) ) (princ) ) Hey, Sorry for the late reply! The code provided was incredibly helpful for what I needed back then. Now, I need it to retain all the original layer properties, including any color types, line weights, line types, and transparency settings, if possible. Any input would be greatly appreciated! Thanks Quote Link to comment Share on other sites More sharing options...
enthralled Posted May 7 Share Posted May 7 (edited) I got this far with the help of ai, it does what I need with the exception of inheriting parent layer Transparency: ;; Modified from pkenewell's lisp: https://www.cadtutor.net/forum/topic/56459-move-to-new-layer-with-suffix/#comment-556088 (defun C:cnl ( / ss cnt el en la llst lt nlst ol suff newLayerProps) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-StartUndoMark AcDoc) (setq ss (ssget ":L") cnt 0) (repeat (sslength ss) (setq el (entget (ssname ss cnt)) la (cdr (assoc 8 el)) cnt (1+ cnt) ) (if (not (member la llst)) (setq llst (cons la llst))) ) (if (setq suff (getstring T "\nEnter suffix for new layers for selected objects: ")) (progn (setq nlst (mapcar '(lambda (x) (strcat x suff)) llst) cnt 0) (foreach i nlst (if (not (tblsearch "LAYER" i)) (progn (setq ol (tblsearch "LAYER" (substr i 1 (- (strlen i) (strlen suff))))) (if ol (progn (setq newLayerProps (entget (tblobjname "LAYER" (cdr (assoc 2 ol))))) (setq newLayerProps (subst (cons 2 i) (assoc 2 newLayerProps) newLayerProps)) (entmakex newLayerProps) ) ) ) ) (setq cnt (1+ cnt)) ) (setq cnt 0) (repeat (sslength ss) (setq en (ssname ss cnt) el (entget en) la (cdr (assoc 8 el)) el (subst (cons 8 (strcat la suff)) (assoc 8 el) el) cnt (1+ cnt) ) (entmod el) ) ) ) (vla-EndUndoMark AcDoc) (princ) ) Edited May 7 by enthralled Quote Link to comment Share on other sites More sharing options...
pkenewell Posted May 7 Share Posted May 7 (edited) On 5/7/2024 at 7:34 AM, enthralled said: I got this far with the help of ai, it does what I need with the exception of inheriting parent layer Transparency: @enthralled A little trickier with getting and setting transparency - but almost all can be done fairly easily with Visual LISP Activex functions. ;; New version by Pkenewell. Uses Visual LISP & ActiveX ;; Updated 5/8/2024 to check for existing layers already with new name. (defun C:CNL ( / acdoc cnt el la llst lt lw lyrs np nl ss su tr) (vl-load-com) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) lyrs (vla-get-layers acdoc) ) (vla-StartUndoMark AcDoc) (if (and (setq ss (ssget ":L")) (/= (setq su (getstring T "\nEnter suffix for new layers for selected objects: ")) "") ) (progn (repeat (setq cnt (sslength ss)) (setq el (entget (ssname ss (setq cnt (1- cnt)))) la (cdr (assoc 8 el)) ) (if (not (member la llst))(setq llst (cons la llst))) ) (foreach n llst (if (not (tblsearch "LAYER" (strcat n su))) (progn (setq ob (vlax-ename->vla-object (setq el (tblobjname "LAYER" n))) col (vla-get-truecolor ob) lt (vla-get-linetype ob) lw (vla-get-lineweight ob) np (vla-get-plottable ob) nl (vla-add lyrs (strcat (vla-get-name ob) su)) tr (getpropertyvalue el "Transparency") ) (vla-put-truecolor nl col) (vla-put-linetype nl lt) (vla-put-lineweight nl lw) (vla-put-plottable nl np) (setpropertyvalue (vlax-vla-object->ename nl) "Transparency" tr) ) ) ) ) ) (vla-EndUndoMark AcDoc) (princ) ) Edited May 8 by pkenewell Edited to correct error in setting transparency. 2 Quote Link to comment Share on other sites More sharing options...
ronjonp Posted May 7 Share Posted May 7 (edited) Here's another one I've had around for a while modified to get the transparency too. It's also good to exclude items that already contain the suffix so you don't end up with duplicate suffixes. (defun c:layersuffix (/ a el f l nl s tm) ;; RJP » 2024-05-08 (or (setq f (getenv "RJP_LayerSuffix")) (setq f (strcat "-" (getenv "username")))) (cond ((and (setq f (cond ((/= "" (setq tm (getstring (strcat "\nEnter suffix [<" f ">]: ")))) tm) (f) ) ) (setq s (ssget ":L" (list '(-4 . "<NOT") (cons 8 (strcat "*" f)) '(-4 . "NOT>")))) ) (setenv "RJP_LayerSuffix" f) (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))) (setq el (entget (tblobjname "layer" (setq l (cdr (assoc 8 (entget e))))) '("AcCmTransparency")) ) (or (tblobjname "layer" (setq nl (strcat l f))) (entmakex (subst (cons 2 nl) (assoc 2 el) el)) ) (entmod (subst (cons 8 nl) (assoc 8 (entget e)) (entget e))) ) ) ) (princ) ) Edited May 8 by ronjonp 2 Quote Link to comment Share on other sites More sharing options...
enthralled Posted May 8 Share Posted May 8 @pkenewell Thanks! Just to point out though, the updated lisp still doesn't take the transparency from the original layer @ronjonp Works perfect. Thanks for sharing! Quote Link to comment Share on other sites More sharing options...
Nikon Posted May 8 Share Posted May 8 (edited) On 07.05.2024 at 22:24, ronjonp said: (defun c: layersuffix (/ a el f l nl s tm) @ronjonp A very convenient code. Edited May 20 by Nikon Quote Link to comment Share on other sites More sharing options...
Steven P Posted May 8 Share Posted May 8 This https://www.theswamp.org/index.php?topic=52473.0 has transparency - the one from Lee mac works if the others don't work this can be used as a basis Quote Link to comment Share on other sites More sharing options...
pkenewell Posted May 8 Share Posted May 8 (edited) 7 hours ago, enthralled said: Thanks! Just to point out though, the updated lisp still doesn't take the transparency from the original layer @enthralled I figured out the error - dumb little mistake; I had the wrong variable name when setting transparency to the original layer instead of the new one I have corrected my post above. @ronjonp Nice code - does the job with DXF. I like how you filter out the possible new names on selection. HOWEVER, The new layer names could still exist and NOT be in the selection set. Still - good idea! I have updated my code above to filter out possible already existing new layers from the creation loop. @Steven P While Lee's code is very creative, it is much shorter to use (getpropertyvalue) and (setpropertyvalue). It wasn't working for me due to a code typo, rather then the method. Edited May 8 by pkenewell 1 Quote Link to comment Share on other sites More sharing options...
Steven P Posted May 8 Share Posted May 8 (edited) I did wonder, never seen you post anything really that doesn't work. A second method is often good for other CAD packages, if one thing doesn't work then an older LISP might. (Lees method might work well for one of mine that creates layers with dxf codes, but not checked that for yet, setproperty will also work well) Edited May 8 by Steven P 1 Quote Link to comment Share on other sites More sharing options...
pkenewell Posted May 8 Share Posted May 8 (edited) 13 hours ago, Nikon said: A very convenient code. And can, please, for the prefix... @Nikon Here is a new version of my code that does either a prefix, suffix, or both: ;; New version by Pkenewell. Uses Visual LISP & ActiveX ;; Updated 5/8/2024 to check for existing layers already with new name. ;; - Also updated for optional Prefix and/or Suffix. ;; - Also added new created layer count. (defun C:CNL ( / acdoc cnt el la llst lt lw lyrs np nl pr ss su tr) (vl-load-com) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) lyrs (vla-get-layers acdoc) ) (vla-StartUndoMark AcDoc) (if (and (setq ss (ssget ":L")) (setq pr (getstring T "\nEnter Prefix for new layers from selected objects <ENTER for None>: ")) (setq su (getstring T "\nEnter suffix for new layers from selected objects <ENTER for None>: ")) (not (= pr su "")) ) (progn (repeat (setq cnt (sslength ss)) (setq el (entget (ssname ss (setq cnt (1- cnt)))) la (cdr (assoc 8 el)) ) (if (not (member la llst))(setq llst (cons la llst))) ) (setq cnt 0) (foreach n llst (if (not (tblsearch "LAYER" (strcat pr n su))) (progn (setq ob (vlax-ename->vla-object (setq el (tblobjname "LAYER" n))) col (vla-get-truecolor ob) lt (vla-get-linetype ob) lw (vla-get-lineweight ob) np (vla-get-plottable ob) nl (vla-add lyrs (strcat pr (vla-get-name ob) su)) tr (getpropertyvalue el "Transparency") ) (vla-put-truecolor nl col) (vla-put-linetype nl lt) (vla-put-lineweight nl lw) (vla-put-plottable nl np) (setpropertyvalue (vlax-vla-object->ename nl) "Transparency" tr) (if (tblsearch "LAYER" (strcat pr n su))(setq cnt (1+ cnt))) ) ) ) (if (> cnt 0)(princ (strcat "\n(" (itoa cnt) ") New Layers Created."))) ) (if (= pr su "")(princ "\nNo Suffix or Prefix Given - No new layers created.")) ) (vla-EndUndoMark AcDoc) (princ) ) Edited May 8 by pkenewell Quote Link to comment Share on other sites More sharing options...
ronjonp Posted May 8 Share Posted May 8 @pkenewell FWIW ;; This (and (= pr "") (= su "")) ;; Could be this (= "" pr su) Also .. I realized that the transparency of a layer is stored as XDATA so: ;; Changing this (setq el (entget (tblobjname "layer" (setq l (cdr (assoc 8 (entget e))))))) ;; To this gets all the layer properties including transparency 8-) (setq el (entget (tblobjname "layer" (setq l (cdr (assoc 8 (entget e))))) '("AcCmTransparency"))) Code updated above. 1 Quote Link to comment Share on other sites More sharing options...
pkenewell Posted May 8 Share Posted May 8 3 hours ago, ronjonp said: FWIW @ronjonp Oh Yes - Thanks. I sometimes forget that you can put multiple terms in the "=" operator. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.