liminnet
发表于 2008-5-16 22:53:00
vken7az2p
发表于 2008-5-16 23:36:00
看看这是不是你要的吧
(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)
)
liminnet
发表于 2008-5-17 00:03:00
vken7az2p
发表于 2008-5-17 08:19:00
原来要求还要改线型喔
那试看看下面改过的吧
(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")
)
liminnet
发表于 2008-5-17 10:30:00
liminnet
发表于 2008-5-17 12:48:00
sailorcwx
发表于 2008-5-17 14:47:00
<p>(defun c:createlayer(/ ACADDOC ACOLOR ALAYER ALINETYPE LAYERNAME LAYEROBJ TXTENT TXTOBJ)<br/> (vl-load-com)<br/> (setq Acaddoc (vla-get-activedocument (vlax-get-acad-object)))<br/> (if (setq Txtent (entsel "\n选择文字"))<br/> (progn<br/> (setq Txtobj (vlax-ename->vla-object (car txtent))<br/> LayerName (vla-get-textstring Txtobj)<br/> Alayer (vla-get-activelayer acaddoc)<br/> Acolor (getvar "CECOLOR")<br/> Alinetype (vla-get-name (vla-get-activelinetype acaddoc))<br/> )<br/> (if (tblsearch "LAYER" LayerName)<br/> (alert (strcat "\n图层" LayerName "已经存在!"))<br/> (progn<br/> (setq Layerobj (vla-add (vla-get-layers acaddoc) LayerName))<br/> (if (or (= Acolor "BYLAYER")(= Acolor "BYBLOCK"))<br/> (vla-put-color Layerobj (vla-get-color Alayer))<br/> (vla-put-color Layerobj Acolor)<br/> )<br/> (if (or (= Alinetype "BYLAYER")(= Acolor "BYBLOCK"))<br/> (vla-put-linetype Layerobj (vla-get-linetype Alayer))<br/> (vla-put-linetype Layerobj Alinetype)<br/> )<br/> (vla-put-activelayer acaddoc Layerobj)<br/> )<br/> )<br/> )<br/> )<br/> (princ)<br/> )</p>
liminnet
发表于 2008-5-17 18:31:00
liminnet
发表于 2008-5-17 20:40:00
sailorcwx
发表于 2008-5-17 21:27:00
(defun c:changelayer(/ENT OBJ OBJCOLOR OBJLAYER)<br/> (vl-load-com)<br/> (if (setq Ent (entsel "\n选择目标对象: "))<br/> (progn<br/> (setq obj (vlax-ename->vla-object (car Ent))<br/> objlayer (vla-get-layer obj)<br/> objcolor (vla-get-color obj)<br/> )<br/> (setvar "CLAYER" objlayer)<br/> (setvar "CECOLOR" (itoa objcolor))<br/> )<br/> )<br/> (princ)<br/> )