Jump to content

Move to new layer with suffix

Chmcdan211

By Chmcdan211
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Chmcdan211 Newbie

Chmcdan211

Posted
Posted

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

  • Replies 29
  • Created
  • Last Reply

Top Posters In This Topic

  • pkenewell

    8

  • enthralled

    5

  • ronjonp

    4

  • Steven P

    3

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

pkenewell
pkenewell

@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 &amp

ronjonp
ronjonp

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.  

pkenewell
pkenewell

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  o

BIGAL Grand Master

BIGAL

Posted
Posted

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)

  • 4 years later...
enthralled Enthusiast

enthralled

Posted
Posted (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 by enthralled
Retain layer properties
dlanorh Mentor

dlanorh

Posted
Posted
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?

BIGAL Grand Master

BIGAL

Posted
Posted

Maybe change the 1 line

  


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

  • 2 weeks later...
pkenewell Experienced

pkenewell

Posted
Posted (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 by pkenewell
  • Like 1
enthralled Enthusiast

enthralled

Posted
Posted

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.

pkenewell Experienced

pkenewell

Posted
Posted (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 by pkenewell
  • Like 1
  • 4 years later...
enthralled Enthusiast

enthralled

Posted
Posted
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

enthralled Enthusiast

enthralled

Posted
Posted (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 by enthralled
pkenewell Experienced

pkenewell

Posted
Posted (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 by pkenewell
Edited to correct error in setting transparency.
  • Like 2
ronjonp Grand Master

ronjonp

Posted
Posted (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 by ronjonp
  • Like 2
enthralled Enthusiast

enthralled

Posted
Posted

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

Nikon Community Regular

Nikon

Posted
Posted (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 by Nikon
pkenewell Experienced

pkenewell

Posted
Posted (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 by pkenewell
  • Like 1
Steven P Grand Master

Steven P

Posted
Posted (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 by Steven P
  • Agree 1
pkenewell Experienced

pkenewell

Posted
Posted (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 by pkenewell
ronjonp Grand Master

ronjonp

Posted
Posted

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

  • Like 1
pkenewell Experienced

pkenewell

Posted
Posted
3 hours ago, ronjonp said:

FWIW

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

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.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...