求一个“块改零层”的程序
求高手帮忙写一个LISP，预实现如下效果：输入命令BT后，将块内所有对象更改到0图层，颜色随层。小弟先再此谢谢了！(defun c:tt ( / e i l n s x )
(if (setq s (ssget '((0 . "INSERT"))))
(repeat (setq i (sslength s))
(if (not (member (setq n (cdr (assoc 2 (entget (ssname s (setq i (1- i))))))) l))
(progn
(setq e (tblobjname "block" n)
l (cons n l)
)
(while (setq e (entnext e))
(setq x (entget e))
(entmod (subst '(8 . "0") (assoc 8 x) x))
)
)
)
)
)
(command "_.regen")
(princ)
)
flyfox1047 发表于 2014-2-12 23:12 static/image/common/back.gif
感谢回复。程序我刚才试过了，针对块内只有单一图层时程序没问题，如果原图块中天正墙体时，会直接关闭CAD而不弹出任何提示，包括错误报告也没有。 sinommw 发表于 2014-2-12 23:36 static/image/common/back.gif
感谢回复。程序我刚才试过了，针对块内只有单一图层时程序没问题，如果原图块中天正墙体时，会直接关闭CA ...
应该是你CAD问题吧 (defun c:test (/ *error* adoc lst_layer func_restore-layers)
(defun *error* (msg)
(func_restore-layers)
(vla-endundomark adoc)
(princ msg)
(princ)
) ;_ end of defun
(defun func_restore-layers ()
(foreach item lst_layer
(vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
(vl-catch-all-apply
'(lambda ()
(vla-put-freeze
(car item)
(cdr (assoc "freeze" (cdr item)))
) ;_ end of vla-put-freeze
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of foreach
) ;_ end of defun
(vl-load-com)
(vla-startundomark
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of vla-startundomark
(if (and (not (vl-catch-all-error-p
(setq selset
(vl-catch-all-apply
(function
(lambda ()
(ssget '((0 . "INSERT")))
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
selset
) ;_ end of and
(progn
(vlax-for item (vla-get-layers adoc)
(setq
lst_layer (cons (list item
(cons "lock" (vla-get-lock item))
(cons "freeze" (vla-get-freeze item))
) ;_ end of list
lst_layer
) ;_ end of cons
) ;_ end of setq
(vla-put-lock item :vlax-false)
(vl-catch-all-apply
'(lambda () (vla-put-freeze item :vlax-false))
) ;_ end of vl-catch-all-apply
) ;_ end of vlax-for
(foreach blk_def
(mapcar
(function
(lambda (x)
(vla-item (vla-get-blocks adoc) x)
) ;_ end of lambda
) ;_ end of function
((lambda (/ res)
(foreach item (mapcar
(function
(lambda (x)
(vla-get-name
(vlax-ename->vla-object x)
) ;_ end of vla-get-name
) ;_ end of lambda
) ;_ end of function
((lambda (/ tab item)
(repeat (setq tabnil
item (sslength selset)
) ;_ end setq
(setq
tab
(cons
(ssname selset
(setq item (1- item))
) ;_ end of ssname
tab
) ;_ end of cons
) ;_ end of setq
) ;_ end of repeat
tab
) ;_ end of lambda
)
) ;_ end of mapcar
(if (not (member item res))
(setq res (cons item res))
) ;_ end of if
) ;_ end of foreach
(reverse res)
) ;_ end of lambda
)
) ;_ end of mapcar
(vlax-for ent blk_def
(vla-put-layer ent "0")
(vla-put-color ent 0)
(vla-put-lineweight ent aclnwtbyblock)
(vla-put-linetype ent "byblock")
) ;_ end of vlax-for
) ;_ end of foreach
(func_restore-layers)
(vla-regen adoc acallviewports)
) ;_ end of progn
) ;_ end of if
(vla-endundomark adoc)
(princ)
) ;_ end of defun 提示Automation 错误。 图层无效 第一的一个程式感觉也很不错！兄弟幸苦了。
页:
[1]