Jump to content

Move to new layer with suffix

Chmcdan211

By Chmcdan211
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Noor-Cad Rookie

Noor-Cad

Posted
Posted
On 5/7/2024 at 10:24 PM, ronjonp said:

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

 

is it possible to add suffix to layers by selecting the text instead of entering?  is it possible to select by window and then select the text and then next selection and so on in a loop and all the objects are shifted to new layers?

  • 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

Steven P Grand Master

Steven P

Posted
Posted

Yes, that is all possible - holiday here today but selecting the text and looping through a selection is possible

  • Thanks 1
pkenewell Experienced

pkenewell

Posted
Posted
On 5/26/2024 at 4:41 PM, Noor-Cad said:

is it possible to add suffix to layers by selecting the text instead of entering?  is it possible to select by window and then select the text and then next selection and so on in a loop and all the objects are shifted to new layers?

Here is an update to my generic version that allows for Text selection. At the prompts, you can enter "?" to go to a Select text prompt. 

;; 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.
;; Updated 5/30/2024 to add ability to select text for prefix/suffix.
(defun C:CNL ( / acdoc cnt el en 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 <\"?\" to Select Text, ENTER for None>: "))
         (if (= pr "?")
            (progn   
               (while
                  (progn
                     (setvar "errno" 0)
                     (setq en (entsel "\nSelect Text Object for Prefix: "))
                     (cond
                        ((= 7 (getvar "errno"))(princ "\nNo Object Selected. Try Again...\n"))
                        ((vl-consp en)
                           (if (not (wcmatch (cdr (assoc 0 (entget (car en)))) "TEXT,MTEXT"))
                              (princ "\nInvalid Object Selected. ")
                           )
                        )
                     )
                  )
               )
               (if en (setq pr (cdr (assoc 1 (entget (car en)))))(setq pr ""))
            )
            T
         )
         (setq su (getstring T "\nEnter suffix for new layers from selected objects <\"?\" to Select Text, ENTER for None>: "))
         (if (= su "?")
            (progn   
               (while
                  (progn
                     (setvar "errno" 0)
                     (setq en (entsel "\nSelect Text Object for Suffix: "))
                     (cond
                        ((= 7 (getvar "errno"))(princ "\nNo Object Selected. Try Again...\n"))
                        ((vl-consp en)
                           (if (not (wcmatch (cdr (assoc 0 (entget (car en)))) "TEXT,MTEXT"))
                              (princ "\nInvalid Object Selected. ")
                           )
                        )
                     )
                  )
               )
               (if en (setq su (cdr (assoc 1 (entget (car en)))))(setq su ""))
            )
            T
         )
         (not (= pr su ""))
       )
       (progn
         (setq en nil)
         (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)
)

 

  • Like 1
Noor-Cad Rookie

Noor-Cad

Posted
Posted
On 5/30/2024 at 7:34 PM, pkenewell said:

Here is an update to my generic version that allows for Text selection. At the prompts, you can enter "?" to go to a Select text prompt. 

;; 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.
;; Updated 5/30/2024 to add ability to select text for prefix/suffix.
(defun C:CNL ( / acdoc cnt el en 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 <\"?\" to Select Text, ENTER for None>: "))
         (if (= pr "?")
            (progn   
               (while
                  (progn
                     (setvar "errno" 0)
                     (setq en (entsel "\nSelect Text Object for Prefix: "))
                     (cond
                        ((= 7 (getvar "errno"))(princ "\nNo Object Selected. Try Again...\n"))
                        ((vl-consp en)
                           (if (not (wcmatch (cdr (assoc 0 (entget (car en)))) "TEXT,MTEXT"))
                              (princ "\nInvalid Object Selected. ")
                           )
                        )
                     )
                  )
               )
               (if en (setq pr (cdr (assoc 1 (entget (car en)))))(setq pr ""))
            )
            T
         )
         (setq su (getstring T "\nEnter suffix for new layers from selected objects <\"?\" to Select Text, ENTER for None>: "))
         (if (= su "?")
            (progn   
               (while
                  (progn
                     (setvar "errno" 0)
                     (setq en (entsel "\nSelect Text Object for Suffix: "))
                     (cond
                        ((= 7 (getvar "errno"))(princ "\nNo Object Selected. Try Again...\n"))
                        ((vl-consp en)
                           (if (not (wcmatch (cdr (assoc 0 (entget (car en)))) "TEXT,MTEXT"))
                              (princ "\nInvalid Object Selected. ")
                           )
                        )
                     )
                  )
               )
               (if en (setq su (cdr (assoc 1 (entget (car en)))))(setq su ""))
            )
            T
         )
         (not (= pr su ""))
       )
       (progn
         (setq en nil)
         (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)
)

 

Thanks Mr. Pkenewell,

Its creating the layers but not shifting the points or objects.

pkenewell Experienced

pkenewell

Posted
Posted

@Noor-Cad I didn't understand that in your short post and it wasn't in the original request for the program. This can be done, but you'll have to wait until I have some more time.

Of course you could try to learn from it and add to the code yourself. That is, after all, what this forum is for.

  • Like 1
  • 2 weeks later...
GNolder Newbie

GNolder

Posted
Posted
On 5/7/2024 at 3:24 PM, ronjonp said:

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

 

@ronjonp This code is very useful. How would it be modified to freeze every new layer?

ronjonp Grand Master

ronjonp

Posted
Posted (edited)

@GNolder Give this a try:
  

(defun c:layersuffix (/ a el f l nl s tm)
  ;; RJP » 2024-06-14
  (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)))
	   ;; Store the new layer names in a list
	   (or (member nl r) (setq r (cons nl r)))
	 )
	 ;; Cycle through new layers and attempt to freeze them
	 (foreach l r
	   (vl-catch-all-apply 'vla-put-freeze (list (vlax-ename->vla-object (tblobjname "layer" l)) -1))
	 )
	)
  )
  (princ)
)

 

Edited by ronjonp
GNolder Newbie

GNolder

Posted
Posted
13 hours ago, ronjonp said:

@GNolder Give this a try:
  

(defun c:layersuffix (/ a el f l nl s tm)
  ;; RJP » 2024-06-14
  (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)))
	   ;; Store the new layer names in a list
	   (or (member nl r) (setq r (cons nl r)))
	 )
	 ;; Cycle through new layers and attempt to freeze them
	 (foreach l r
	   (vl-catch-all-apply 'vla-put-freeze (list (vlax-ename->vla-object (tblobjname "layer" l)) -1))
	 )
	)
  )
  (princ)
)

 

@ronjonp This works perfectly! Thank you!

ronjonp Grand Master

ronjonp

Posted
Posted
On 6/15/2024 at 6:05 AM, GNolder said:

@ronjonp This works perfectly! Thank you!

:beer:

  • 3 months later...
pondpepo9 Apprentice

pondpepo9

Posted
Posted
On 5/8/2024 at 2:24 AM, ronjonp said:

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

 

"I'm seeking assistance in creating a Lisp function that can generate a new layer with a custom name and move a selected object to this layer while preserving all of its original properties, including true color and color book information. I'm currently using AutoCAD LT 2024 and typically work on Layer 0. Could you please help me modify an existing Lisp function to achieve this? I'm particularly impressed with its ability to copy true colors accurately. Thank you for your time and expertise."

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