图层与劳动成果保护
<p>请高手帮我编下，谢谢！原来的图层上的颜色保持不变，但是所有层删除掉，全部归到0层！这样可以按颜色打图，但是编辑起来就不容易了！这样也助于保护自己的劳动成果！！！急用！！谢谢！！！</p> 本帖最后由 作者 于 2010-9-18 20:48:55 编辑;简短程序。保留颜色和线型。
(defun c:tt ()
(setvar "CMDECHO" 0)
(setq lent nil)
(while (setq lent (tblnext "LAYER" (not lent)))
(if (/= (setq ln (cdr(assoc 2 lent))) "0") (progn
(if (setq ss1 (ssget "X" (list (cons 8 ln) (cons 62 256))))
(command ".CHPROP" ss1 "" "C" (cdr(assoc 62 lent)) "LA" "0" "")
)
(if (setq ss1 (ssget "X" (list (cons 8 ln) (cons 6 "BYLAYER"))))
(command ".CHPROP" ss1 "" "LT" (cdr(assoc 6 lent)) "LA" "0" "")
)
(if (setq ss1 (ssget "X" (list (cons 8 ln))))
(command ".CHPROP" ss1 "" "LA" "0" "")
)
))
)
(command ".PURGE" "ALL" "*" "N" ".PURGE" "ALL" "*" "N")
(setvar "CMDECHO" 1)
(princ)
)
(defun c:tt(/ *Acad* *AcDocument* en ss n obj objlayer layername color )
(setq *Acad* (vlax-get-acad-object)
*AcDocument* (vla-get-activedocument *Acad*)
)
(setq ss (ssget "x" '((-4 . "<not") (8 . "0")(-4 . "not>"))))
(setq n 0)
(if ss
(repeat (sslength ss)
(setq en (ssname ss n))
(setq obj (vlax-ename->vla-object en))
(setq color (vla-get-color obj))
(if (= color 256)
(progn
(setq layername (vla-get-layer obj))
(setq objlayer (vla-item (vla-get-layers *AcDocument*) layername))
(setq color (vla-get-color objlayer))
(vla-put-color obj color)
(vla-put-layer obj "0")
)
(vla-put-layer obj "0")
)
(setq n (1+ n))
)
)
)
本帖最后由 作者 于 2010-9-16 14:11:00 编辑 <br /><br /> ZZXXQQ发表于2010-9-15 21:28:00static/image/common/back.gif;简短程序。保留颜色和线型。
以下内容需要帖子数达到5才可以浏览
以下内容为程序代码:
(defun c:tt ()
(setvar \"CMDECHO\" 0)
<p>。。。</p>
<p> </p></font></td></tr>
<tr style="DISPLAY: none">
<td id="copycode47428"></td></tr></tbody></table></p>
<p>
<hr/>
<p></p></div>
<p>只能对实体线型、颜色是随层才起作用哦！对非随层就无效喽！达不到楼主的要求啦！</p> 本帖最后由 作者 于 2010-9-18 15:44:46 编辑 <br /><br /> <p><font face="Verdana"></font> </p>
<p><font face="Verdana"><strong>;;;师兄 QQ 361865648 版本20100918</strong></font></p>
<p> </p>
<p><font face="Verdana"></font><font face="Verdana"> </p>
<p><font face="Verdana"></font> </p>
<p><font face="Verdana">;;;师兄 QQ 361865648 版本20100918</font></p>
<p><font face="Verdana">(defun c:TEST()<br/>;;;用新的组码值替换原值<br/>(defun dxfupd (ent dxfcode newval / elst newlst)<br/> (setq elst (entget ent))<br/> (setq newlst (append elst (list (cons dxfcode newval))))<br/> (entmod newlst)<br/> (entupd ent)<br/>)</font></p>
<p><font face="Verdana">;;;将实体移动到0层,并保持实体的线型和颜色不变<br/>(defun updcolandlt (ent / entlst layername laylst laycol ltype)<br/> (setq entlst (entget ent))<br/> (setq layername (cdr (assoc 8 entlst)))<br/> (setq laylst (tblsearch "layer" layername))<br/> (setq laycol (cdr (assoc 62 laylst)))<br/> (setq ltype (cdr (assoc 6 laylst)))<br/> (if (not (assoc 6 entlst))<br/> (dxfupd ent 6 ltype)<br/> )</font></p>
<p><font face="Verdana"> (if (assoc 62 entlst)<br/> (dxfupd ent 8 "0")<br/> (progn<br/> (dxfupd ent 62 laycol)<br/> )<br/> )<br/>)</font></p><font face="Verdana">
<p><br/>(setq entss (ssget "x" '((0 . "~insert")))) ;_非块<br/> (if (not entss) (vl-exit-with-value 0))</p>
<p>(setq i 0)<br/>(repeat (sslength entss)<br/> (setq curent (ssname entss i))<br/> (setq i (1+ i))<br/> (updcolandlt curent)<br/> (dxfupd curent 8 "0")<br/>)</p>
<p><br/>(setq blkss (ssget "x" '((0 . "insert"))))<br/> (if (not blkss) (vl-exit-with-value 1))<br/>(setq i 0)<br/>(repeat (sslength blkss)<br/> (setq curblk (ssname blkss i))<br/> (setq i (1+ i))<br/> (setq blklst (entget curblk))<br/> (setq blkname (cdr (assoc 2 blklst))) ;_块名<br/> (setq blkdef (tblsearch "block" blkname)) ;_块定义<br/> (setq einblk (cdr (assoc -2 blkdef))) ;_块中第一个图元<br/> (updcolandlt einblk)<br/> (dxfupd einblk 8 "0")<br/> (while (and<br/> (setq einblk (entnext einblk))<br/> (setq elst (entget einblk))</p>
<p> (/= (cdr (assoc 0 elst)) "SEQEND")<br/> )</p>
<p> (updcolandlt einblk)<br/> (dxfupd einblk 8 "0")<br/> )<br/> (dxfupd curblk 8 "0")<br/>)</p>
<p>;;;删除其余的层<br/> (setq layer(tblnext "layer" t))<br/> (setq layname(cdr(assoc 2 layer)));_层名<br/>;;; (setq layent(tblobjname "layer" layername));_第一个层<br/> (setq laylst(list layname))<br/> (while (setq layer(tblnext "layer"))<br/> (setq layname(cdr(assoc 2 layer)))<br/> (setq laylst(cons layname laylst))<br/> )</p>
<p> (mapcar '(lambda (x)<br/> (if (/= "0" x)<br/> (progn<br/> <br/> (setq err(vl-catch-all-apply 'vla-delete (list (vlax-ename->vla-object (tblobjname "layer" x)))))<br/> (if (VL-CATCH-ALL-ERROR-P err)(princ (strcat "\n不能删除 " x " 层"))<br/> (princ (strcat "\n " x " 层已成功删除!")))</p>
<p><br/> ))<br/>(princ)<br/> )</p>
<p><br/> laylst)</p>
<p><br/>(princ)<br/> )<br/></font></p>
<p> </p>
<p><strong>命令名: test</strong></p>
<p><strong>花了二十分钟简单的写了一下,程序没有防错功能,自已完善一下,支持单层图块</strong></p></font> 有没有 lisp教程呢，AUTOCAD help全英文，看着头疼呢 很实用,谢谢 程序太好了..学习学习学习 很是适用，非常不错的 非常不错的工具，如果再能把里面进行锁定加密就更好了
页:
[1]