求改lsp,点中文字后就可以以文字内容建立图层,但颜色总是白色,改随层

vken7az2p

看看这是不是你要的吧

3. (defun c:JTHWAX598 (/ ANS EN LN OC TN)
4. (prompt "\n**<用途:依文字名称新建图层>**")
5. (defun LA-TO-VLA (ename)
6.   (vlax-ename->vla-object ename)
7.   )
8. (defun AR_DXF (#code #ename)
9.   (cdr (assoc #code (entget #ename)))
10.   )
11. (setvar "cmdecho" 0)  ;;关闭指令行回应
12. (command "undo" "be") ;;设置程序起始
13. (setq EN (car (nentselp "\n选取文字:")))
14. (setq TN (AR_DXF 1 EN)) ;文字内容
15. (setq TN (vl-string-subst "" ":" TN))
16. (setq TN (vl-string-subst "" "%" TN))
17. (setq OC (vla-get-color (LA-TO-VLA EN))) ;颜色代码
18. (setq LN (AR_DXF 8 EN)) ;图层名称
19. (if (= (type (tblsearch "layer" TN)) 'list)
20.   (print "图层已经存在!")
21.   (progn
22.    (cond
23.     ((= OC 0) (setq ANS 7))
24.     ((= OC 256)
25.      (setq ANS (cdr (assoc 62 (tblsearch "layer" LN))))
26.      )
27.     (t (setq ANS OC))
28.     )
29.    (MKLA TN ANS)
30.    (vla-put-layer (LA-TO-VLA EN) TN)
31.    )
32.   )
33. (command "undo" "e") ;;设置程序结尾
34. (prin1)
35. )

(defun c:JTHWAX598 (/ ANS EN LN OC TN) (prompt "\n**<用途:依文字名称新建图层>**") (defun LA-TO-VLA (ename)   (vlax-ename->vla-object ename)   ) (defun AR_DXF (#code #ename)   (cdr (assoc #code (entget #ename)))   ) (setvar "cmdecho" 0)  ;;关闭指令行回应 (command "undo" "be") ;;设置程序起始 (setq EN (car (nentselp "\n选取文字:"))) (setq TN (AR_DXF 1 EN)) ;文字内容 (setq TN (vl-string-subst "" ":" TN)) (setq TN (vl-string-subst "" "%" TN)) (setq OC (vla-get-color (LA-TO-VLA EN))) ;颜色代码 (setq LN (AR_DXF 8 EN)) ;图层名称 (if (= (type (tblsearch "layer" TN)) 'list)   (print "图层已经存在!")   (progn    (cond     ((= OC 0) (setq ANS 7))     ((= OC 256)      (setq ANS (cdr (assoc 62 (tblsearch "layer" LN))))      )     (t (setq ANS OC))     )    (MKLA TN ANS)    (vla-put-layer (LA-TO-VLA EN) TN)    )   ) (command "undo" "e") ;;设置程序结尾 (prin1) )

vken7az2p

原来要求还要改线型喔
那试看看下面改过的吧

3. (defun C:JTHWAX609 (/ ANS EN LAS LN LS OC TN )
4. (prompt "\N**<用途:依文字名称新建图层>**")
5. (defun LA-TO-VLA (ENAME)
6.   (vlax-ename->vla-object ENAME)
7.   )
9. (defun AR_DXF (#CODE #ENAME)
10.   (cdr (assoc #CODE (entget #ENAME)))
11.   )
13. (defun MKLA_V2 (A B C)
14.   (if (= (tblsearch "LAYER" A) NIL)
15.    (command "_.LAYER" "M" A "C" B A "L" C A "")
16.    (command "_.LAYER" "T"   A     "S"   A "C"   B
17.      A   "U" A     "ON"  A   "L" C     A
18.      ""
19.      )
20.    )
21.   )
23. (setvar "CMDECHO" 0)
24. (command "UNDO" "BE")
25. (setq EN (car (nentselp "\N选取文字:")))
26. (setq TN (AR_DXF 1 EN))
27. (setq TN (vl-string-subst "" ":" TN))
28. (setq TN (vl-string-subst "" "%" TN))
29. (setq OC (vla-get-color (LA-TO-VLA EN)))
30. (setq LN (AR_DXF 8 EN))
31. (setq LS (AR_DXF 6 EN))
32. (if (= (type (tblsearch "LAYER" TN)) 'list)
33.   (print "图层已经存在!")
34.   (progn
35.    (cond
36.     ((= OC 0)
37.      (setq ANS 7)
38.      (if LS
39.       (setq LAS LS)
40.       (setq LAS "")
41.       )
42.      )
43.     ((= OC 256)
44.      (if LS
45.       (setq LAS LS)
46.       (setq LAS "")
47.       )
48.      (setq ANS (cdr (assoc 62 (tblsearch "LAYER" LN))))
49.      )
50.     (t
51.      (setq ANS OC)
52.      (if LS
53.       (setq LAS LS)
54.       (setq LAS "")
55.       )
56.      )
57.     )
58.    (MKLA_V2 TN ANS LAS)
59.    (vla-put-layer (LA-TO-VLA EN) TN)
60.    )
61.   )
62. (command "UNDO" "E")
63. )

(defun C:JTHWAX609 (/ ANS EN LAS LN LS OC TN ) (prompt "\N**<用途:依文字名称新建图层>**") (defun LA-TO-VLA (ENAME)   (vlax-ename->vla-object ENAME)   ) (defun AR_DXF (#CODE #ENAME)   (cdr (assoc #CODE (entget #ENAME)))   ) (defun MKLA_V2 (A B C)   (if (= (tblsearch "LAYER" A) NIL)    (command "_.LAYER" "M" A "C" B A "L" C A "")    (command "_.LAYER" "T"   A     "S"   A "C"   B      A   "U" A     "ON"  A   "L" C     A      ""      )    )   ) (setvar "CMDECHO" 0) (command "UNDO" "BE") (setq EN (car (nentselp "\N选取文字:"))) (setq TN (AR_DXF 1 EN)) (setq TN (vl-string-subst "" ":" TN)) (setq TN (vl-string-subst "" "%" TN)) (setq OC (vla-get-color (LA-TO-VLA EN))) (setq LN (AR_DXF 8 EN)) (setq LS (AR_DXF 6 EN)) (if (= (type (tblsearch "LAYER" TN)) 'list)   (print "图层已经存在!")   (progn    (cond     ((= OC 0)      (setq ANS 7)      (if LS       (setq LAS LS)       (setq LAS "")       )      )     ((= OC 256)      (if LS       (setq LAS LS)       (setq LAS "")       )      (setq ANS (cdr (assoc 62 (tblsearch "LAYER" LN))))      )     (t      (setq ANS OC)      (if LS       (setq LAS LS)       (setq LAS "")       )      )     )    (MKLA_V2 TN ANS LAS)    (vla-put-layer (LA-TO-VLA EN) TN)    )   ) (command "UNDO" "E") )

sailorcwx

(defun c:createlayer(/ ACADDOC ACOLOR ALAYER ALINETYPE LAYERNAME LAYEROBJ TXTENT TXTOBJ)
  (vl-load-com)
  (setq Acaddoc (vla-get-activedocument (vlax-get-acad-object)))
  (if (setq Txtent (entsel "\n选择文字"))
    (progn
      (setq Txtobj (vlax-ename->vla-object (car txtent))
     LayerName (vla-get-textstring Txtobj)
     Alayer (vla-get-activelayer acaddoc)
     Acolor (getvar "CECOLOR")
     Alinetype (vla-get-name (vla-get-activelinetype acaddoc))
     )
      (if (tblsearch "LAYER" LayerName)
 (alert (strcat "\n图层" LayerName "已经存在!"))
 (progn
   (setq Layerobj (vla-add (vla-get-layers acaddoc) LayerName))
   (if (or (= Acolor "BYLAYER")(= Acolor "BYBLOCK"))
     (vla-put-color Layerobj (vla-get-color Alayer))
     (vla-put-color Layerobj Acolor)
     )
   (if (or (= Alinetype "BYLAYER")(= Acolor "BYBLOCK"))
     (vla-put-linetype Layerobj (vla-get-linetype Alayer))
     (vla-put-linetype Layerobj Alinetype)
     )
   (vla-put-activelayer acaddoc Layerobj)
   )
 )
      )
    )
  (princ)
  )

sailorcwx

(defun c:changelayer(/ENT OBJ OBJCOLOR OBJLAYER)
  (vl-load-com)
  (if (setq Ent (entsel "\n选择目标对象: "))
    (progn
      (setq obj (vlax-ename->vla-object (car Ent))
     objlayer (vla-get-layer obj)
     objcolor (vla-get-color obj)
     )
      (setvar "CLAYER" objlayer)
      (setvar "CECOLOR" (itoa objcolor))
      )
    )
  (princ)
  )