Layer change of polyline according to inner text value

[bit_Cad2018]

Hi, users need a lisp routine for layer change of polyline according to inner text value.

[CodeDing · Accepted solution]

Got bored today.. Hope this helps

(defun c:TTL ( / MultiAssoc ssPL ePL ptsPL cnt ssTXT eTXT num lyr)
  ;; Text To Layer
  ;; Helper Function(s)
  (setq MultiAssoc (lambda (k l / i) (if (setq i (assoc k l)) (cons (cdr i) (MultiAssoc k (cdr (member i l)))))))
  ;; Begin work
  (prompt "\nSelect Polylines surrounding Text: ")
  (if (setq ssPL (ssget '((0 . "LWPOLYLINE"))))
    (progn
      (prompt (strcat "\n" (itoa (setq cnt (sslength ssPL))) " Polylines selected."))
      (repeat cnt
        (prompt (strcat "\nSearching for text inside Polyline " (itoa cnt) "... "))
        (setq ePL (ssname ssPL (setq cnt (1- cnt))))
        (setq ptsPL (MultiAssoc 10 (entget ePL)))
        (if (and (setq ssTXT (ssget "_CP" ptsPL '((0 . "TEXT"))))
                 (setq eTXT (ssname ssTXT 0))
                 (setq num (read (getpropertyvalue eTXT "TextString")))
                 (numberp num)
                 (setq num (itoa num))
            );and
          (progn
            (prompt (strcat "Text '" num "' Found."))
            (if (not (setq lyr (tblobjname "LAYER" num)))
              (setq lyr
                (entmakex
                  (list (cons 0 "LAYER") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbLayerTableRecord")
                        (cons 2 num) (cons 6 "Continuous") (cons 62 7) (cons 70 0)
                  );list
                );entmakex
              );setq
            );if
            (setpropertyvalue ePL "LayerId" lyr)
            (setpropertyvalue eTXT "LayerId" lyr)
          );progn
        ;else
          (prompt "No Numerical Text Found.")
        );if
      );repeat
    );progn
  ;else
    (prompt "\nNo Polylines were selected.")
  );if
  (prompt "\nTTL Complete.")
  (princ)
);defun

[pbejse · Accepted solution]

(defun c:LFT ( / ss i pts e ent Tent pts  ss1 e1 lyer)
  (if
    (or
      (setq ss (ssget "_I" '((0 . "LWPOLYLINE"))))
      (setq ss (ssget '((0 . "LWPOLYLINE"))))
    )
    (progn
      (repeat (setq i (sslength ss))
            (setq e   (ssname ss (setq i (1- i)))
                  pts (apply 'append
                             (mapcar '(lambda (x)
                                            (if (= 10 (car x)) (list (cdr x))))
                                     (setq ent (entget e)))))
            (if (And
                      (setq ss1 (ssget "_CP" pts '((0 . "TEXT"))))
                      (setq Tent (entget (ssname ss1 0))
                            lyer (cdr (assoc 1 Tent)))
                      (snvalid lyer))
                  (foreach
                         itm  (list ent Tent)
                        (entmod (subst (Cons 8 lyer)
                                       (assoc 8 itm)
                                       itm))
                        )
                  )
            )
      )
    )
(princ)
)

[hak_vz · Accepted solution]

Takes care when text is not fully enclosed in polyline

(defun c:CHLL( / take take2 pointlist2d i ss tt eo to_move th to pts sst te txt )
	(defun take (amount lst / ret)(repeat amount (setq ret (cons (car lst) (take (1- amount) (cdr lst))))))
	(defun take2 (lst) (take 2 lst))
	(defun pointlist2d (lst / ret) (while lst (setq	ret (cons (take 2 lst) ret) lst (cddr lst))) (reverse ret))
	(princ "\nSelect area boundary poylines to change layer >")
	(setq i -1 ss (ssget '((0 . "LWPOLYLINE,TEXT")(8 . "Area_Boundary"))) tt (ssadd))
	(while (< (setq i (1+ i)) (sslength ss))
		(setq eo (vlax-ename->vla-object (ssname ss i)))
		(cond
			((= (vlax-get eo 'ObjectName) "AcDbText")
				(setq to_move (cons (ssname ss i) to_move))
			)
		)
	)
	(foreach e to_move
		(if (ssmemb e ss) (setq ss(ssdel e ss)))
		(setq tt (ssadd e tt))
	)
	(setq to_move nil)
	(setq i -1)
	(setq th (vlax-get (vlax-ename->vla-object (ssname tt 0)) 'Height))
	(while (< (setq i (1+ i)) (sslength tt))
		(setq to (vlax-ename->vla-object (ssname tt i)))
		(vlax-put to 'Height 0.05)
	)
	(setq i -1)
	(cond 
		((and ss)
			(while (< (setq i (1+ i)) (sslength ss))
				(setq eo (vlax-ename->vla-object (ssname ss i)))
				(setq pts (pointlist2d(vlax-get eo 'Coordinates)))
				(setq sst (ssget "_CP" pts '((0 . "TEXT"))))
				(cond 
					((and sst)
						(setq te (ssname sst 0))
						(setq to (vlax-ename->vla-object te))
						(setq txt (vlax-get to 'TextString))
						(if (not(tblsearch "Layer" txt))
							(entmake 
								(list 
									(cons 0 "LAYER")
									(cons 100 "AcDbSymbolTableRecord")
									(cons 100 "AcDbLayerTableRecord")
									(cons 2  txt)
									(cons 62 7)
									(cons 70 0)
								)
							)
						)
						(vlax-put eo 'Layer txt)
						(vlax-put to 'Layer txt)
					)
				)
			)
		)
	)
	(cond 
		((and tt)
			(setq i -1)
			(while (< (setq i (1+ i)) (sslength tt))
				(setq to (vlax-ename->vla-object (ssname tt i)))
				(vlax-put to 'Height th)
			)
		)
	)
	(princ "\nDone!")
	(princ)
)

[bit_Cad2018]

Thanks, @CodeDing, @pbejse, And @hak_vz 

This Routine is very useful... 🙏