lucas_3333 发表于 2014-3-25 22:51:14

源码，分享两个清理程序

本帖最后由 lucas_3333 于 2014-3-28 08:04 编辑

http://i1.hoopchina.com.cn/user/700/15694700/AlbumImg139204070521270_400*225.gif


哈哈，不多说了，上附件了



qazxswk 发表于 2022-3-26 04:48:38

我这有个更简单的。

(defun c:11()
(dictremove(namedobjdict)"ACAD_DGNLINESTYLECOMP")
(vl-cmdf "-SCALELISTEDIT" "R" "Y" "E"
"_audit" "Y"
"_purge" "A" "" "N"
)
(princ))

669423907 发表于 2014-3-26 15:42:08

感觉这个更好用些
;;清理图层 www.xdcad.net
(defun c:PU(/ thisdrawing ss lyrlst olderr myerr)
(setvar"clayer""0")         ;; 当前层为0层
(defun myerr (msg)
    (if (/= msg "取消")
      (princ "\*取消*")
    )
    (vla-endundomark thisdrawing)
    (setq *error* olderr
myerr   nil
    )
    (princ)
)
(setvar "cmdecho" 0)
(setq thisdrawing
(vlax-get-property
   (vlax-get-acad-object)
   'activedocument
)
)
(vla-startundomark thisdrawing)
(setq olderr *error*
*error* myerr
)
(vlax-map-collection
    (vlax-get-property thisdrawing 'layers)
    '(lambda (lyr / name s tf)
       (setq name (vla-get-name lyr))
       (if (or (setq tf (= (vla-get-freeze lyr) :vlax-true))
       (= (vla-get-layeron lyr) :vlax-false)
   )
(progn
   (if (= (vla-get-lock lyr) :vlax-true)
   (vla-put-lock lyr :vlax-false)
   )
   (if tf
   (setq lyrlst (cons name lyrlst))
   )
   (vla-put-freeze lyr :vlax-false)
   (if (setq s (ssget "X" (list (cons 8 name))))
   (vl-cmdf ".erase" s "")
   )
)
       )
   )
)
;|(if lyrlst
    (vlax-map-collection
      (vlax-get-property thisdrawing 'blocks)
      '(lambda (b / bn)
(setq bn (vla-get-name b))
(if (and (/= bn "*MODEL_SPACE")
(/= bn "*PAPER_SPACE")
(not (wcmatch bn "`*PAPER_SPACE?"))
   )
   (vlax-map-collection
   b
   '(lambda (x)
(if (vl-position (vla-get-layer x) lyrlst)
(vla-delete x)
)
      )
   )
)
       )
    )
)|;
(if (setq ss (ssget "x" '((2 . "*网易*,*土木在线*,*园林站图块*"))))
    (vl-cmdf ".erase" ss "")
)
(vla-purgeall thisdrawing)
(vla-purgeall thisdrawing)
(vla-purgeall thisdrawing)
;(vla-zoomextents (vla-get-application thisdrawing))
(vla-save thisdrawing)
(vla-endundomark thisdrawing)
(setq *error* olderr
myerr nil
)

;删除空组及数量为1的组定义 狂刀lxx 2011-5-10 2005.10 http://bbs.mjtd.com/thread-86821-1-1.html
(vlax-for obj (vla-get-groups (vla-get-activedocument(vlax-get-acad-object)))
(if (< (vla-get-count obj)2)(vla-delete obj)))
;删除匿名组
(vlax-for obj (vla-get-groups (vla-get-activedocument(vlax-get-acad-object)))
(if (wcmatch (vla-get-name obj)"'**")(vla-delete obj)))

(princ))

ysq101 发表于 2014-3-25 23:05:39

清理什么啊？？

香田里浪人 发表于 2014-3-26 07:07:09

无法下载，不知能清理什么啊

自贡黄明儒 发表于 2014-3-26 08:11:43

本帖最后由 自贡黄明儒 于 2014-3-26 08:28 编辑

第一个要安装ET，调用了overkill
LZ你应该整理一下

zfsaaa 发表于 2014-3-26 09:39:37

LZ你应该整理一下,亲水？

vvcd 发表于 2014-3-26 12:34:36

好用不，能清理什么呢，楼主最好说明哈

lucas_3333 发表于 2014-3-28 08:08:54

再上一个

pengfei2010 发表于 2017-10-24 16:21:06

回帖是一种美德！感谢楼主的无私分享 谢谢

alexmai 发表于 2017-10-27 23:44:00

都很好用，学习了
页: [1] 2 3 4
查看完整版本: 源码，分享两个清理程序