删除图中（包括图块内）所有的WIPEOUT实体

newer · 发表于 2016-9-3 14:42:14

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

下面代码删除图中所有（包括图块内）的WIPEOUT实体，考虑了冻结层和锁定层的情况。

程序框架如下，稍加修改，你也可以删除其他类的实体。

[it618postdisplay>0]

(vl-load-com)(defun _prelayers (adoc / item layers prop tmp)
(vlax-for item (vla-get-layers adoc)
(if (not (wcmatch (vla-get-name item "*|*")))
(setq layers (cons (append (list item)
(mapcar (function (lambda (prop / tmp)
(setq tmp (vlax-get-property item prop))
(vl-catch-all-apply (function (lambda () (vlax-put-property item prop :vlax-false))))
(cons prop tmp)
) ;_ end of lambda
) ;_ end of function
'("freeze" "lock")
) ;_ end of mapcar
) ;_ end of append
layers
) ;_ end of cons
) ;_ end of setq
) ;_ end of if
) ;_ end of vlax-for
)

(vl-load-com)(defun _prelayers (adoc / item layers prop tmp) 
  (vlax-for item (vla-get-layers adoc) 
    (if (not (wcmatch (vla-get-name item "*|*"))) 
      (setq layers (cons (append (list item) 
                                 (mapcar (function (lambda (prop / tmp) 
                                                     (setq tmp (vlax-get-property item prop)) 
                                                     (vl-catch-all-apply (function (lambda () (vlax-put-property item prop :vlax-false)))) 
                                                     (cons prop tmp) 
                                                     ) ;_ end of lambda 
                                                   ) ;_ end of function 
                                         '("freeze" "lock") 
                                         ) ;_ end of mapcar 
                                 ) ;_ end of append 
                         layers 
                         ) ;_ end of cons 
            ) ;_ end of setq 
      ) ;_ end of if 
    ) ;_ end of vlax-for 
)

[/it618postdisplay]

(defun c:remove-wipeout (/ adoc layers count err)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setq layers (_prelayers adoc))
(setq count 0
err 0
) ;_ end of setq
(vlax-for blk_def (vla-get-blocks adoc)
(if (equal (vla-get-isxref blk_def) :vlax-false)
(vlax-for ent blk_def
(if (wcmatch (strcase (vla-get-objectname ent)) "*WIPEOUT*")
(if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (vla-erase ent)))))
(setq err (1+ err))
(setq count (1+ count))
) ;_ end of if
) ;_ end of if
) ;_ end of vlax-for
) ;_ end of if
) ;_ end of vlax-for
(foreach item layers
(foreach prop (cdr item)
(vl-catch-all-apply (function (lambda () (vlax-put-property (car item) (car prop) (cdr prop)))))
) ;_ end of foreach
) ;_ end of foreach
(princ (strcat "\nErased wipeout : " (itoa count) "\nError erasing : " (itoa err)))
(vla-endundomark adoc)
(princ)
) ;_ end of defun

(defun c:remove-wipeout (/ adoc layers count err) 
  (vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object)))) 
  (setq layers (_prelayers adoc)) 
  (setq count 0 
        err 0 
        ) ;_ end of setq 
  (vlax-for blk_def (vla-get-blocks adoc) 
    (if (equal (vla-get-isxref blk_def) :vlax-false) 
      (vlax-for ent blk_def 
        (if (wcmatch (strcase (vla-get-objectname ent)) "*WIPEOUT*") 
          (if (vl-catch-all-error-p (vl-catch-all-apply (function (lambda () (vla-erase ent))))) 
            (setq err (1+ err)) 
            (setq count (1+ count)) 
            ) ;_ end of if 
          ) ;_ end of if 
        ) ;_ end of vlax-for 
      ) ;_ end of if 
    ) ;_ end of vlax-for 
  (foreach item layers 
    (foreach prop (cdr item) 
      (vl-catch-all-apply (function (lambda () (vlax-put-property (car item) (car prop) (cdr prop))))) 
      ) ;_ end of foreach 
    ) ;_ end of foreach 
  (princ (strcat "\nErased wipeout : " (itoa count) "\nError erasing  : " (itoa err))) 
  (vla-endundomark adoc) 
  (princ) 
) ;_ end of defun

lucas3 · 发表于 2016-9-3 16:37:42

看看，学习

q3_2006 · 发表于 2016-9-3 17:26:21

块内做比较麻烦..删除还好吧..

HLCAD · 发表于 2016-9-3 17:52:17

程序实用，感谢版主！

liusir@615 · 发表于 2016-9-4 21:49:39

haohaohaohaohaohaohao

yoyoho · 发表于 2016-9-5 07:14:13

学习!看一看!!!

819534890 · 发表于 2016-9-5 09:03:12

学习学习学习

shuaier · 发表于 2016-9-11 10:53:05

测试下效果！！

pedromax · 发表于 2016-9-17 12:01:35

學習了~
感謝樓主分享!

panliang9 · 发表于 2016-10-26 09:06:05

我有一些图是反复加了很多wipeout ,在需要一次性的把它们清掉的时候非常有用！

1425361224 · 发表于 2017-2-23 15:58:16

我来学习学习这个东西

向嘟嘟 · 发表于 2017-2-23 17:11:38

正需要，支持楼主大人了！

不是我 · 发表于 2017-2-27 14:40:05

我要看看怎么写的

yufeng37 · 发表于 2017-2-28 22:31:58

本帖最后由 yufeng37 于 2017-2-28 22:39 编辑

报告楼主，我运行下来有报错！

[检查文字 <未命名-0> 正在加载... SELECTION]
..
; 警告: 参数太少: (WCMATCH (vla-get-Name ITEM "*|*"))
.
; 检查完成.

命令: remove-wipeout
; 错误: 实参太多
; 出错后重置

pps658712 · 发表于 2017-3-15 13:03:57

看看，学习

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

[每日一码] 删除图中（包括图块内）所有的WIPEOUT实体

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。