图层与劳动成果保护

linx1314 · 发表于 2010-9-14 22:36

请高手帮我编下，谢谢！原来的图层上的颜色保持不变，但是所有层删除掉，全部归到0层！这样可以按颜色打图，但是编辑起来就不容易了！这样也助于保护自己的劳动成果！！！急用！！谢谢！！！

ZZXXQQ · 发表于 2010-9-15 21:28

本帖最后由作者于 2010-9-18 20:48:55 编辑

;简短程序。保留颜色和线型。

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0

Gu_xl · 发表于 2010-9-15 12:23

(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))
)
)
)

Gu_xl · 发表于 2010-9-15 21:53

本帖最后由作者于 2010-9-16 14:11:00 编辑

ZZXXQQ发表于2010-9-15 21:28:00;简短程序。保留颜色和线型。以下内容需要帖子数达到5才可以浏览以下内容为程序代码: (defun c:tt () (setvar \"CMDECHO\" 0)

。。。

caiqs · 发表于 2010-9-18 15:00

本帖最后由作者于 2010-9-18 15:44:46 编辑

;;;师兄 QQ 361865648 版本20100918

;;;师兄 QQ 361865648 版本20100918

(defun c:TEST()
;;;用新的组码值替换原值
(defun dxfupd (ent dxfcode newval / elst newlst)
(setq elst (entget ent))
(setq newlst (append elst (list (cons dxfcode newval))))
(entmod newlst)
(entupd ent)
)

;;;将实体移动到0层,并保持实体的线型和颜色不变
(defun updcolandlt (ent / entlst layername laylst laycol ltype)
(setq entlst (entget ent))
(setq layername (cdr (assoc 8 entlst)))
(setq laylst (tblsearch "layer" layername))
(setq laycol (cdr (assoc 62 laylst)))
(setq ltype (cdr (assoc 6 laylst)))
(if (not (assoc 6 entlst))
(dxfupd ent 6 ltype)
)

(if (assoc 62 entlst)
    (dxfupd ent 8 "0")
    (progn
      (dxfupd ent 62 laycol)
    )
)
)

(setq entss (ssget "x" '((0 . "~insert")))) ;_非块
(if (not entss) (vl-exit-with-value 0))

(setq i 0)
(repeat (sslength entss)
(setq curent (ssname entss i))
(setq i (1+ i))
(updcolandlt curent)
(dxfupd curent 8 "0")
)

(setq blkss (ssget "x" '((0 . "insert"))))
(if (not blkss) (vl-exit-with-value 1))
(setq i 0)
(repeat (sslength blkss)
(setq curblk (ssname blkss i))
(setq i (1+ i))
(setq blklst (entget curblk))
(setq blkname (cdr (assoc 2 blklst))) ;_块名
(setq blkdef (tblsearch "block" blkname)) ;_块定义
(setq einblk (cdr (assoc -2 blkdef))) ;_块中第一个图元
(updcolandlt einblk)
(dxfupd einblk 8 "0")
(while (and
(setq einblk (entnext einblk))
(setq elst (entget einblk))

(/= (cdr (assoc 0 elst)) "SEQEND")
)

(updcolandlt einblk)
(dxfupd einblk 8 "0")
)
(dxfupd curblk 8 "0")
)

;;;删除其余的层
(setq layer(tblnext "layer" t))
(setq layname(cdr(assoc 2 layer)));_层名
;;; (setq layent(tblobjname "layer" layername));_第一个层
(setq laylst(list layname))
(while (setq layer(tblnext "layer"))
    (setq layname(cdr(assoc 2 layer)))
    (setq laylst(cons layname laylst))
    )

(mapcar '(lambda (x)
      (if (/= "0" x)
        (progn

        (setq err(vl-catch-all-apply 'vla-delete (list (vlax-ename->vla-object (tblobjname "layer" x)))))
        (if (VL-CATCH-ALL-ERROR-P err)(princ (strcat "\n不能删除 " x " 层"))
   (princ (strcat "\n " x " 层已成功删除!")))

))
(princ)
)

laylst)

(princ)
)

命令名: test

花了二十分钟简单的写了一下,程序没有防错功能,自已完善一下,支持单层图块

iwx007 · 发表于 2010-10-5 23:03

有没有 lisp教程呢，AUTOCAD help全英文，看着头疼呢

578749467 · 发表于 2010-11-29 12:37

很实用,谢谢

白皮猪 · 发表于 2012-11-28 23:44

程序太好了..学习学习学习

aaxxgg · 发表于 2012-12-14 14:20

很是适用，非常不错的

野狼谷/〈M〉 · 发表于 2013-6-7 22:40

非常不错的工具，如果再能把里面进行锁定加密就更好了

账号		自动登录	找回密码
密码			注册

图层与劳动成果保护

评分