Two part lisp. Create layers with a -text suffix then move all text to new layers.

LDShaw · ‎04-27-2023

I have a lot of dwg's where I want to separate all the text to it's own layers but leave the other objects where they are.

I know I need to get a list of layers.
create the list with a -text suffix

I've not gotten done commenting it out but here it is.

;; RJP » 2023-05-09 wrote most of this routine. 
;;; DESCRIPTION
;;; 2023-05-09
;;;	add prefix text- to new layers that have text 
;;; Dig into blocks and do the same.
;;;Lonnie
;;;
(defun c:TSP (/ a d la ln pre)

  (vlax-for l (setq la (vla-get-layers (setq d (vla-get-activedocument (vlax-get-acad-object)))))
    (cond ((= -1 (vlax-get l 'lock)) (vlax-put l 'lock 0) (setq a (cons l a))))
  )
  (setq pre "TEXT-")
  (vlax-for b (vla-get-blocks d)
    (if	(= 0 (vlax-get b 'isxref))
      (vlax-for	o b
	(cond ((and (vlax-write-enabled-p o)
		    (vlax-property-available-p o 'textstring)
		    (not (wcmatch (strcase (setq ln (vla-get-layer o))) (strcat pre "*" )))
	       )
	       (entmod (append (entget (vlax-vla-object->ename o)) (list (cons 8 (strcat pre ln)))))
	      )
	)
      )
    )
  )
  (foreach l a (vlax-put l 'lock -1))
  (if (ssget "_X" '((0 . "INSERT") (66 . 1)))
    (command "_.Attsync" "_N" "*")
  )
  (vla-regen d acallviewports)
  (princ)
)

Then I need to gather up the text and move it to the new layer.
This is where I've been running into problem.

SeeMSixty7 · ‎04-27-2023

I would propose getting a selection set of all text objects/entities. And then run through each object and get its layer name. Then if the -text later for it does not exist then create the layer. And then change the entity layer and then move to the next entity.
good luck

Visit my blog
http://www.seemsixty7.com/blog/

paullimapa · ‎04-27-2023

if you want to also change texts inside blocks then you'll have to cycle through the block table and identify the text objects within each block and change those layers

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

LDShaw · ‎04-28-2023

SeeMSixty7, I thought of that but text (layers) can be done so many different ways it's easier to just create the duplicate layers and be done with it.
paullimapa, that would be nice but I am not sure it's a needed feature. (yet)

I think something along the lines of

(ssget "_X" (list (cons 0 "TEXT,MTEXT,LEADER")

to gather the entities and then repeating vlax-map-collection would work but it just fails.

paullimapa · ‎04-28-2023

Then there are Attributes if you want to include those. But show us the rest of the code as to what fails.

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

LDShaw · ‎04-28-2023

Here is what it looks like now. I have commented it a little better but now it's broken.

(defun c:tupd (/ *error* la_doc la_lst lyr_lst suf txt_lst)

  (defun *error* (msg)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
    (princ (strcat "\nAn Error: <" msg "> occurred."))
    (princ)
  );_end_*error*_defun

  ;; Define some variables that will be used later
  (setq 
    la_doc (vlax-get-property (vlax-get-acad-object) 'activedocument) ;; Get the active AutoCAD document
    la_lst (vlax-get-property la_doc 'layers) ;; Get the collection of layers in the document
    suf "-text" ;; The suffix that will be appended to the layer names to create the new layers
  );end_setq

																									  

  ;; Loop through all the selected entities in the drawing and create a list of all the text entities
  (vlax-for ent (vla-get-activeselectionset (vlax-get-property la_doc 'selectionsets))
    (if (= "TEXT" (cdr (assoc 0 (entget ent))))
      (setq txt_lst (cons ent txt_lst))
    );_end_if
  );_end_vlax-for

  ;; Loop through all the layers in the document
  (vlax-map-collection la_lst 
    '(lambda (x) 
      (setq lyr_lst (cons (vlax-get-property x 'name) lyr_lst))
      ;; Check if there is a layer with the same name but with the "-text" suffix. If not, create a new layer with that name.
      (if (not (member (strcat (vlax-get-property x 'name) suf) lyr_lst))
        (vla-add la_lst (strcat (vlax-get-property x 'name) suf))
      );_end_if
      ;; Filter the list of text entities to only those on the current layer, and then check if any of those entities already have the "-text" suffix. If none of them do, add the suffix to the layer name.
      (if (not (member (strcat (vlax-get-property x 'name) suf) (mapcar 'strcase (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (strcase (vlax-get-property x 'Layer)) (strcase (vlax-get-property x 'name)))) txt_lst)))))
        (vla-add la_lst (strcat (vlax-get-property x 'name) suf))
      );_end_if
    );_end_lambda
  );_end_vlax-map-collection

  ;; Loop through all the text entities and change their layer to the corresponding layer with the "-text" suffix using the CHPROP command.
  (foreach ent txt_lst
    (vl-cmdf "_.chprop" ent "" "l" (strcat (vlax-get-property ent 'Layer) suf))
  )
  ;_end_foreach

  (princ)
)

Hope it helps.

paullimapa · ‎04-28-2023

not sure but try changing this:

(vl-cmdf "_.chprop" ent "" "l" (strcat (vlax-get-property ent 'Layer) suf)

to this:

(vl-cmdf "_.chprop" ent "" "_la" (strcat (vlax-get-property ent 'Layer) suf "")

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

LDShaw · ‎04-28-2023

lol Fails differently now.

Command: (LOAD "C:/Users/Desktop/text to new layer rev 1.lsp") bad function: T

Kent1Cooper · ‎04-28-2023

I have a suggestion for a different approach. If you change an object's Layer by manipulating its entity data, rather than with CHPROP or VLA properties, then if the Layer doesn't exist, it will be created in the process! So all you need to do is find all the Text, and for each Text object, (subst) the Layer entry [DXF code 8] in its entity data list, with the "-text" suffix added to its Layer name [if it doesn't already end that way]. If the Layer exists, the Text will simply be taken to it; if not, it will make the Layer and go into it.

[Any such Layers created this way will be default color 7, so you may want to add something if you have a preferred color -- a simple Layer command could assign a preferred text color to all Layers whose names end in "-text" [any case], all at once.]

In simplest terms, and minimally tested:

(defun C:TSL ; = Text to Suffixed Layers
  (/ ss n tdata tlay)
  (if (setq ss (ssget "_X" '((0 . "TEXT"))))
    (repeat (setq n (sslength ss)); then
      (setq
        tdata (entget (ssname ss (setq n (1- n)))); entity data list
        tlay (cdr (assoc 8 tdata)); current Layer name
      ); setq
      (if (not (wcmatch (strcase tlay) "*-TEXT")); doesn't already end that way [any case]
        (entmod (subst (cons 8 (strcat tlay "-text")) (assoc 8 tdata) tdata)); then
      ); if
    ); repeat
  ); if
  (prin1)
)

Kent Cooper, AIA

paullimapa · ‎04-28-2023

try this

; tupd Create layers with a -text suffix then move all text to new layers.
; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/two-part-lisp-create-layers-with-a-text-suffix-then-move-all/m-p/11928738/highlight/false#M447459
(defun c:tupd (/ *error* la_doc la_lst lyr_lst suf txt_lst ActiveX-Collection newlyrnam)

  (defun *error* (msg)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
     (princ (strcat "\nAn Error: <" msg "> occurred."))
    )
    (princ)
  );_end_*error*_defun

  ;; Define some variables that will be used later
  (setq 
    la_doc (vlax-get-property (vlax-get-acad-object) 'activedocument) ;; Get the active AutoCAD document
    la_lst (vlax-get-property la_doc 'layers) ;; Get the collection of layers in the document
    suf "-text" ;; The suffix that will be appended to the layer names to create the new layers
  );end_setq

  ;; if there is a selection of text objects in drawing except on layer 0 or Defpoints
  (if (ssget "_X" '((0 . "TEXT")(-4 . "<NOT") (8 . "0,Defpoints")(-4 . "NOT>")))
   (progn
  ;; get selection set as vla objects
    (setq ActiveX-Collection (vla-get-activeselectionset la_doc))
  ;; Loop through all the text entities and change their layer to the corresponding layer with the "-text" suffix using the CHPROP command.
    (vlax-for ent ActiveX-Collection
     (setq newlyrnam (strcat (vla-get-layer ent) suf)) ; get new layer name from text object
     (vlax-invoke-method la_lst 'Add newlyrnam) ; add new layer name
     (vla-put-layer ent newlyrnam) ; change text object to new layer name
    ) ;_end_foreach
   ) ; progn
  ) ; if text object selection
  (princ)
) ; defun

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

ronjonp · ‎04-28-2023

@Kent1Cooper You can also filter out those items directly like so:

(setq ss (ssget "_X" '((0 . "TEXT") (8 . "~*-TEXT"))))

@LDShaw You need to add this to your code otherwise you'll end up with duplicate suffixes.

(vlax-for ent activex-collection
  (if ;; RJP » Check that the object does not have the suffix already
      ;;otherwise you'll end up with "LAYERNAME-TEXT-TEXT-TEXT etc..
      (not (wcmatch (strcase (vla-get-layer ent)) (strcat "*" (strcase suf))))
    (progn (setq newlyrnam (strcat (vla-get-layer ent) suf)) ; get new layer name from text object
	   (vlax-invoke-method la_lst 'add newlyrnam) ; add new layer name
	   (vla-put-layer ent newlyrnam) ; change text object to new layer name
    )
  )
) ;_end_foreach

LDShaw · ‎04-28-2023

Thank you!

Both worked. I ended up using Kent1Cooper's so I did not have to exclude defpoints and 0 layers. I also added mtext and leaders to...
I will now let people test it. Hopefully it will work as well for them as my simple test did.

(defun C:TSL (/ ss n txt tdata tlay); = Text to Suffixed Layers
    (if (setq ss (ssget "_X" '((0 . "TEXT,MTEXT,LEADER"))))
    (repeat (setq n (sslength ss)); then
											
      (setq
        txt (ssname ss (setq n (1- n)))
        tdata (entget txt); entity data list
        tlay (cdr (assoc 8 tdata)); current Layer name
      ); setq
      (if (not (wcmatch (strcase tlay) "*-TEXT")); doesn't already end that way [any case]
        (entmod (subst (cons 8 (strcat tlay "-text")) (assoc 8 tdata) tdata)); then
	   
      ); if
    ); repeat
  ); if
  (prin1)
)

Thank You.
All

I will accept both solutions as soon as it's tested.

paullimapa · ‎04-28-2023

**modified code so layer creation is simplified***

you maybe interested in this revised version which takes care of creating the new layers matching the properties of the current text layer and if on a locked layer will unlock so can change the text to the new text layer

; tupd Create layers with a -text suffix then move all text, mtext & leader to new layers.
; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/two-part-lisp-create-layers-with-a-text-suffix-then-move-all/m-p/11928738/highlight/false#M447459
(defun c:tupd (/ *error* la_doc la_lst suf ss ActiveX-Collection curlyrnam newlyrnam curlayobj layboj)

  (defun *error* (msg)
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))
     (princ (strcat "\nAn Error: <" msg "> occurred."))
    )
    (princ)
  );_end_*error*_defun

  ;; Define some variables that will be used later
  (setq 
    la_doc (vlax-get-property (vlax-get-acad-object) 'activedocument) ;; Get the active AutoCAD document
    la_lst (vlax-get-property la_doc 'layers) ;; Get the collection of layers in the document
    suf "-TEXT" ;; The suffix that will be appended to the layer names to create the new layers
  );end_setq

  ;; if there is a selection of text, mtext & leader objects in drawing filtering out layers already with -TEXT suffix
  (if (setq ss(ssget "_X" '((0 . "TEXT,MTEXT,LEADER")(8 . "~*-TEXT"))))
   (progn
  ;; get selection set as vla objects
    (setq ActiveX-Collection (vla-get-activeselectionset la_doc))
  ;; Loop through all the text entities and change their layer to the corresponding layer with the "-TEXT" suffix 
    (vlax-for ent ActiveX-Collection
      (setq newlyrnam (strcat (setq curlyrnam (vla-get-layer ent)) suf)) ; get current & set new layer name from text object
      (if(not(tblsearch"LAYER" newlyrnam)) ; if new layer name doesn't already exist
       (progn ; then create new layer with TEXT suffix using current TEXT layer properties of Color, LayerOn, Freeze, Linetype, Lineweight, Lock and Plottable
        (setq curlayobj (vla-Item la_lst curlyrnam)) ; get current layer name object
        (setq layobj (vlax-invoke-method la_lst 'Add newlyrnam)) ; add new layer name
        (foreach itm '("Color""LayerOn""Freeze""Linetype""Lineweight""Lock""Plottable")
         (vlax-put-property layobj itm (vlax-get-property curlayobj itm))
        )
       ) ; progn
      ) ; if
      (if (= ':vlax-true (vlax-get-property (setq curlayobj (vla-Item la_lst curlyrnam)) 'Lock)) ; check if layer is locked
        (progn ; then
         (vlax-put-property curlayobj 'Lock ':vlax-false) ; unlock
         (vla-put-layer ent newlyrnam) ; change text object to new layer name
         (vlax-put-property curlayobj 'Lock ':vlax-true) ; relock
        )  
        (vla-put-layer ent newlyrnam) ; else just change text object to new layer name
      ) ; if
    ) ;_end_foreach
    (princ(strcat"\nChanged Total of [" (itoa (sslength ss)) "] TEXT,MTEXT,LEADER Objects.")) ; report results
   ) ; progn
   (princ"\nNo TEXT,MTEXT,LEADER Objects found.") ; report nothing found
  ) ; if text object selection
  (princ)
) ; defun

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

LDShaw · ‎05-08-2023

Thank you all. This is doing exactly what I asked of you all.

As paullimapa predicted (And I said they told me that's not needed.) They now want to move the text in blocks over to their own layers. Not only blocks but annotative ones. Here is about 1/16 of a file I was presented.

paullimapa · ‎05-08-2023

The sample dwg also contains lots of blocks with attributes which obviously look like TEXT objects as well.

my prediction is that you'll eventually want those attributes to be included.

What can get tricky with that is the attributes are typically left on layer 0 while the block objects themselves are actually on a unique layer.

In that case which would it be? layer 0-text or the block layer with -text suffix?

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

ronjonp · ‎05-09-2023

@LDShaw wrote:

Thank you all. This is doing exactly what I asked of you all.

As paullimapa predicted (And I said they told me that's not needed.) They now want to move the text in blocks over to their own layers. Not only blocks but annotative ones. Here is about 1/16 of a file I was presented.

@LDShaw Try this:

(defun c:foo (/ a d la ln suf)
  ;; RJP » 2023-05-09
  (vlax-for l (setq la (vla-get-layers (setq d (vla-get-activedocument (vlax-get-acad-object)))))
    (cond ((= -1 (vlax-get l 'lock)) (vlax-put l 'lock 0) (setq a (cons l a))))
  )
  (setq suf "-TEXT")
  (vlax-for b (vla-get-blocks d)
    (if	(= 0 (vlax-get b 'isxref))
      (vlax-for	o b
	(cond ((and (vlax-write-enabled-p o)
		    (vlax-property-available-p o 'textstring)
		    (not (wcmatch (strcase (setq ln (vla-get-layer o))) (strcat "*" suf)))
	       )
	       (entmod (append (entget (vlax-vla-object->ename o)) (list (cons 8 (strcat ln suf)))))
	      )
	)
      )
    )
  )
  (foreach l a (vlax-put l 'lock -1))
  (if (ssget "_X" '((0 . "INSERT") (66 . 1)))
    (command "_.Attsync" "_N" "*")
  )
  (vla-regen d acallviewports)
  (princ)
)

paullimapa · ‎05-09-2023

very nicely done...

curious as to if there's an advantage to converting the text from vla object to entity before changing its layer:

(entmod (append (entget (vlax-vla-object->ename o)) (list (cons 8 (strcat ln suf)))))

could you have coded like this:

(vla-put-layer o (strcat ln suf))

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

ronjonp · ‎05-09-2023

@paullimapa This is true but you have to make sure the layer exists or it will bomb.

	       (vla-add la (strcat ln suf))
	       (vla-put-layer o (strcat ln suf))

paullimapa · ‎05-09-2023

Got it. Thanks for the insight.

Paul Li
IT Specialist
@The Office
Apps & Publications | Video Demos

ronjonp · ‎05-09-2023

@paullimapa wrote:

Got it. Thanks for the insight.

Cheers! 🙂

Community

Two part lisp. Create layers with a -text suffix then move all text to new layers.

Two part lisp. Create layers with a -text suffix then move all text to new layers.

Two part lisp. Create layers with a -text suffix then move all text to new layers.