Move to new layer with suffix

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

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)

September 19, 2019

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

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?

September 20, 2019

Maybe change the 1 line


(command "CHPROP" obj "" "LA" layname "") 
(command "CHPROP" (ssget) "" "LA" layname "")

October 2, 2019

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

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.

October 3, 2019

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

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

May 7

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

Tuesday at 02:07 PM

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 Wednesday at 01:13 PM by pkenewell
Edited to correct error in setting transparency.

Tuesday at 07:24 PM

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 Wednesday at 04:22 PM by ronjonp

Wednesday at 06:23 AM

@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!

Wednesday at 06:34 AM

11 hours ago, ronjonp said:
(defun c: layersuffix (/ a el f l nl s tm)

@ronjonp A very convenient code. And can, please, for the prefix...

Wednesday at 08:44 AM

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

Wednesday at 01:09 PM

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 Wednesday at 01:33 PM by pkenewell

Wednesday at 01:16 PM

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 Wednesday at 01:18 PM by Steven P

Wednesday at 01:28 PM

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 Wednesday at 07:48 PM by pkenewell

Wednesday at 04:22 PM

@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.

Wednesday at 07:47 PM

3 hours ago, ronjonp said:

FWIW

@ronjonp Oh Yes - Thanks. I sometimes forget that you can put multiple terms in the "=" operator.

Move to new layer with suffix

Recommended Posts

Chmcdan211

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

enthralled

Link to comment

Share on other sites

dlanorh

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

enthralled

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

enthralled

Link to comment

Share on other sites

enthralled

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

ronjonp

Link to comment

Share on other sites

enthralled

Link to comment

Share on other sites

Nikon

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

ronjonp

Link to comment

Share on other sites

pkenewell

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity