自定义清理

llsheng_73

1. ;|(Mpurge DOC'((groups t)(Layouts)(SelectionSets )(blocks)(layers)(textstyles)(dimstyles)(Linetypes)(Viewports)(Views)(UserCoordinateSystems)))
   
2. 清理Doc文档下的空组、删除布局、空选择集、清理未引用块、字体样式、标注样式、线型、视口、视图、ucs;
   
3. lst表每一项第一个为文档下的各种集合，出现第二项且非nilt时，清理该集合下的空对象，无第二项或第二项非真时，尽可能删除集合下所有对象;
   
4. DOC为当前CAD对象下的任一文档对象或dbx对象，doc为nil或非文档对象时，被自动设置为当前文档|;
   
5. (defun Mpurge(DOC LST / l n)
   
6.   (or(not(VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY'vlax-get-property(List doc 'Database))))
   
7.      (setq DOC(vlax-get-property(vlax-get-acad-object)'ActiveDocument)))
   
8.   (vl-every(function(lambda(x / a b)
   
9.                       (or(VL-CATCH-ALL-ERROR-P(setq a(VL-CATCH-ALL-APPLY 'vlax-get-property(list doc(car x)))))
   
10.                          (progn(setq n(1+(vlax-get-property a'count)))
    
11.                            (while(<(setq l(vlax-get-property a'count))n)
    
12.                              (setq n l)
    
13.                              (vlax-for y a
    
14.                                (and(if(cdr x)(<(vlax-get-property y'count)1)t)
    
15.                                    (VL-CATCH-ALL-APPLY 'vlax-invoke-method(list y 'delete))))))
    
16.                          t)))LST))

;|(Mpurge DOC'((groups t)(Layouts)(SelectionSets )(blocks)(layers)(textstyles)(dimstyles)(Linetypes)(Viewports)(Views)(UserCoordinateSystems)))<br /> 清理Doc文档下的空组、删除布局、空选择集、清理未引用块、字体样式、标注样式、线型、视口、视图、ucs;<br /> lst表每一项第一个为文档下的各种集合，出现第二项且非nilt时，清理该集合下的空对象，无第二项或第二项非真时，尽可能删除集合下所有对象;<br /> DOC为当前CAD对象下的任一文档对象或dbx对象，doc为nil或非文档对象时，被自动设置为当前文档|;<br /> (defun Mpurge(DOC LST / l n)<br />   (or(not(VL-CATCH-ALL-ERROR-P(VL-CATCH-ALL-APPLY'vlax-get-property(List doc 'Database))))<br />      (setq DOC(vlax-get-property(vlax-get-acad-object)'ActiveDocument)))<br />   (vl-every(function(lambda(x / a b)<br />                       (or(VL-CATCH-ALL-ERROR-P(setq a(VL-CATCH-ALL-APPLY 'vlax-get-property(list doc(car x)))))<br />                          (progn(setq n(1+(vlax-get-property a'count)))<br />                            (while(<(setq l(vlax-get-property a'count))n)<br />                              (setq n l)<br />                              (vlax-for y a<br />                                (and(if(cdr x)(<(vlax-get-property y'count)1)t)<br />                                    (VL-CATCH-ALL-APPLY 'vlax-invoke-method(list y 'delete))))))<br />                          t)))LST))

测试时，我换2台电脑用2006清理嵌套块出错，但其它版本CAD下测试正常，不知道究竟是电脑问题还是CAD2006的问题

tigcat

;经过实测,楼主大大函数非常好用,感觉加一句"repeat"效果好一点
(setq LST '((layers)(groups t)(blocks)(blocks t)(textstyles)(dimstyles)) ;增加标注样式
(defun Mpurge (LST)

(repeat 3   ;一次好像清不干净,来3次
  (vl-every
    '(lambda (x / a b)
       (or
         (VL-CATCH-ALL-ERROR-P
           (setq a (VL-CATCH-ALL-APPLY
                     'vlax-get-property
                     (list (vlax-get-property      ;若用于dbx,修改此处
                             (vlax-get-acad-object)
                             'ActiveDocument
                           )
                           (car x)
                     )
                   )
           )
         )
         (if (cdr x)
           (vlax-for y a
             (and
               (< (vlax-get-property y 'count) 1)
               (VL-CATCH-ALL-APPLY 'vlax-invoke-method (list y 'delete))
             )
           )
           (vlax-for y a
             (VL-CATCH-ALL-APPLY 'vlax-invoke-method (list y 'delete))
           )
         )
         t
       )
     )
    lst
  )
);end repeat
)

llsheng_73

tigcat 发表于 2022-7-18 22:13
;经过实测,楼主大大函数非常好用,感觉加一句"repeat"效果好一点
(setq LST '((la ...

repeat实际上是没必要的，但为什么会一次搞不干净，其实是相互牵扯，比如一个图层没有任何东西，但有一个未被参照的图块里边用到了该图层，那么在这个图块被清理前，这个图层是清理不掉的，另外文字样式也一样，就算图中没有任何文字或属性，但同样的一个块里边用到了这个文字样式，它同样也只能在块被清理之后才能被清理掉

这样一来，由于一次性清理没太考究顺序问题，所以就会理清不干净，需要repeat几次后它就干净了，实际上，注意一下顺序就可以一次清理干净

tigcat

llsheng_73 发表于 2022-7-19 08:17
嵌套块确实会一次清理不掉，因为
假如A引用B，一般说来blocks里边，A先于B出现，但需要反过来先清理掉B ...

谢谢楼主耐心回复，这个程序最大的好处就是可以用来dbx，实现不开图批量清理。非常方便。这些天刚好在搜这个，搜遍全网，用lisp实现的就只看到1.2个，1个是楼主的，另外0.2个是MP的，他提供了伪源码。谢谢楼主大侠的经典源码！

tigcat

我怀疑这个清理功能可以用于dbx

llsheng_73

tigcat 发表于 2022-7-18 17:58
我怀疑这个清理功能可以用于dbx

(vlax-get-property(vlax-get-acad-object)'ActiveDocument)
这部分换成DBX对象就可以了

3278

tigcat

llsheng_73 发表于 2022-7-18 19:33
(vlax-get-property(vlax-get-acad-object)'ActiveDocument)
这部分换成DBX对象就可以了

谢谢大佬,多日的疑惑或许马上就要解开,我先试验,这可是连沼泽MP都没具体回答的一个难题.

magicheno

感谢大佬分享

伪书虫86

收藏备用

逍遥无声