neo 发表于 2005-4-17 22:04:56

[试用]:发个清理无用组的东东(VBA)

不包含任何图元的组留在CAD文档中占用了不少资源,尤其是反复编辑的图形。。
本人习惯用lisp加载VBA.。看下附件中的lisp文件救治道用法了。。

782150yhm 发表于 2005-4-18 18:30:45

楼主里面的后缀名不是。lsp的文件怎么加载

neo 发表于 2005-4-18 20:51:55

这个程序是用VBA写的,压缩包里有个Clear_grp.lsp文件,
打开,然后改一下"clear_grp.dvb"所在的目录。加载lisp就可以了。适用于ACAD2005。
键入 “clg”就可以运行了。完了 "clear_grp.dvb"会被卸载。不会留在内存里。只有很小的Clear_grp.lsp会留下。。

tjdxzp 发表于 2005-5-12 03:15:05

谢谢楼主,已经下载!

andyhua5240 发表于 2005-5-14 21:41:30

谢谢楼主的东东,希望理正能加入和这个类似的清理无用组的程序。因为理正的很多对象都是用组存在的,而别人如果不用理正的话,就会删除组,这样组的信息仍然留存在了CAD文件中。希望QUN能加入清理无用组的程序。谢谢!

Qun 发表于 2005-5-15 07:49:18

不用理正组也照样有用处。

秋枫 发表于 2005-5-16 22:42:22

昨天打开一张地形图,6M多。一使用Group命令AutoCAD就死掉。初步判断是图中的组太多了。用用楼主的清除空组程序试试,一样的死法。想来是对话框创建列表时出问题了,几百条可以忍受,但几十万个组下来,标准Group命令都死翘翘了,不要说你的这个程序。其中绝大部分是空组。

最后,只好自己动手写清除空组的命令行版本的程序,不要对话框了。大概运行了二十分钟有的吧,清除了几十万个空组。清完后保存DWG,原来6M的文件变成了1M。

(vl-load-com)

(defun C:PurgeGroup (/ gnList doc groups g)
(princ
    "\n此程序搜索不包含任何物体的空组并清除之\n"
)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq groups (vla-get-groups doc))
(vlax-for g groups
    (princ "\n分析组:")
    (princ (vla-get-name g))
    (if        (= (vla-get-count g) 0)
      (progn
        (princ (strcat "......删除空组" (vla-get-name g)))
        (vla-delete g)
      )
    )
    (princ)
)
)

andyhua5240 发表于 2005-5-18 19:11:24

谢谢,秋枫大哥,要的就是这个程序!

Quelea 发表于 2005-5-19 20:05:41

忽然想到,只包含一个物体的组也是没有意义的,是不是也应该清理掉?

修改一下:上面的PurgeGroup.lsp中的那行:
(if (= (vla-get-count g) 0)
改为
(if (< (vla-get-count g) 2)
可以清理空组或只含一个物体的组。

雅南 发表于 2005-6-3 08:21:31

多谢了,我就是需要这样的东西呀

立顿红茶 发表于 2005-6-6 11:29:26

这两天我也正为这个发愁。
请教各位高手,我的一张总图在清理重线和清理图元的时候,就自动跳出来了。怎么办?还是方案的初期,画到后面会更大,图层更多了,就怕画到画到就突然了跳出来了。
在分解一个块的时候也自动跳出来了。

zweilili 发表于 2005-6-15 23:34:48

我试用了这几周觉得这个程序已经非常完善了,若秋枫大侠不介意理正完全可以加入这个有用的东东!

eachy 发表于 2005-6-18 20:45:00

还可以用更高效率的代码,49999个组 9.x 秒

秋枫 发表于 2005-6-21 20:35:16

最初由 eachy 发布
还可以用更高效率的代码,49999个组 9.x 秒

有空我试试vlax-map-collection看。(你的这个测试是否在命令行上打印信息?)

eachy 发表于 2005-6-22 00:04:20

打印信息是为了测试用的

;;程序开始
(setq s              (getvar "date")
      seconds (* 86400.0 (- s (fix s)))
)
;;程序结束
(princ "耗时 ")
(princ
(- (* 86400.0 (- (getvar "date") (fix (getvar "date"))))
   seconds
)
)
(princ " s!")
页: [1] 2 3
查看完整版本: [试用]:发个清理无用组的东东(VBA)