need to put every text in alayer with same text name and color every layer different

[the_ameral]

need to put every text in al

 

ayer with same text name and color every layer different

[_Tharwat · Accepted solution]

Something like this?

(defun c:Test ( / s i n c e r)
  ;; Tharwat - 22.Jul.2021	;;
  (and (princ "\nSelect texts to move to separate layer names : ")
       (setq c 1 i -1 s (ssget "_:L" '((0 . "TEXT"))))
       (while (setq i (1+ i) n (ssname s i))
         (or (setq r (tblsearch "LAYER" (setq v (cdr (assoc 1 (setq e (entget n)))))))
             (and (setq r (snvalid v))
                  (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord") (cons 2 v) (cons 62 c) '(70 . 0))))
             )
         (and r (entmod (subst (cons 8 v) (assoc 8 e) e)))
         (and (= (setq c (1+ c)) 256) (setq c 1))
         )
       )
  (princ)
  )
                  

[hak_vz · Accepted solution]

This one will use only names of layers that are already created and will not create new layers.

If text content equals to one of already created layer it will put that text entity to particular layer. You have to define layer properties (in this case color) in layer manager.

(defun c:ctl ( / collectLayerObjects ss i layers e f)
(defun collectLayerObjects ( / ret) 
	(reverse (vlax-for lay (vlax-get (vla-get-activedocument (vlax-get-acad-object)) 'Layers)
	(setq ret (cons (cons (vlax-get lay 'Name) lay)ret))))
)
(setq ss (ssget "X" '((0 . "TEXT"))))
(setq i -1 layers (mapcar 'strcase (mapcar 'car (collectLayerObjects))))
(while (< (setq i (1+ i)) (sslength ss))
(setq e (vlax-ename->vla-object(ssname ss i)) f (vlax-get e 'TextString))
(if (member (strcase f) layers) (vlax-put e 'Layer f))
)
(princ)
)

[the_ameral]

thank you it work very good

[the_ameral]

it work well thanks alot

[pbejse · Accepted solution]

See if you can spot the difference @the_ameral 

(defun c:String2Layer ( / ss color ent str )
    (if (setq color 0
	      ss (ssget "_:L" '((0 . "TEXT"))))
     	(repeat (Setq i (sslength ss))
	  (setq ent (entget (ssname ss (setq i (1- i)))))
	  (setq str (cdr (assoc 1 ent)))
	  (cond
	    ((not (snvalid str))	)
	    ((and
	       (or
	     	(tblsearch "Layer" (strcase str))
		     (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")
					 '(100 . "AcDbLayerTableRecord")
					 (cons 2 str) (cons 62 (setq color (1+ color )))
					 '(70 . 0)
				   )
			  )
	     	)
	     (/= (strcase (cdr (assoc 8 ent)))(strcase str))
	       )
	     	(entmod (subst (cons 8 str) (assoc 8 ent) ent)))
	    )
	  (if (= color 255)(setq color 0))
	  )
     )(princ)
    )

HTH

[the_ameral]

it work well thank you ...