另类Purge

admin

另类Purge

1. 偶尔遇到一种特别大的DWG，上百兆了，打开后看着也没有多少Entity，用Purge显示没有可清的东西，经过分析Dwg中附加的信息太多，可能包括Xdat、Dict、Xrecord等等，如果一个个处理可能要逐一分析，太麻烦，下面用简单的步骤和简单的几个语句实现另类“Purge”
2. 1 打开Dwg，这里太大的DWG可能在32bit系统和CAD会很慢，为了最简单处理，确保CAD仅有这一个文档打开
3. 2 文件-〉新建一个文档，用默认设置
4. 3 打开Vlisp编辑器
5. 4 把下面几句粘贴进去，加载，慢慢等待，Ok
6. 5 保存图形，前后对比看看能瘦身多少
7. 说明：
8. a：字体样式复制是必须的，否则可能无法显示部分字体
9. b:  图块复制也是必须的，否则Insert无法生成
10. c：图层复制非必须，复制仅是为了保持原汁原味，否则可能都是一种白色
12. 声明：本语句处理有风险，后果自负！
14. [pcode=lisp,true]
15. (setq *acad* (vlax-get-acad-object)
16.       doc    (vla-item (vla-get-documents *acad*) 0)
17. )
18. ;;复制另外图形图层
19. (vlax-for lay (vla-get-layers doc)
20.   (entmake (entget (vlax-vla-object->ename lay)))
21. )
22. ;;复制另外图形字体
23. (vlax-for sty (vla-get-textstyles doc)
24.   (entmake (entget (vlax-vla-object->ename sty)))
25. )
26. ;;构造另外图块定义
27. (vlax-for obj (vla-get-blocks doc)
28.   (if (not (wcmatch (strcase (vla-get-name obj)) "*SPACE*"))
29.     (setq bl (cons obj bl))
30.   )
31. )
32. ;;拷贝另外图块定义
33. (vla-CopyObjects
34.   doc
35.   (vlax-safearray-fill
36.     (vlax-make-safearray
37.       vlax-vbObject
38.       (cons 0 (1- (length bl)))
39.     )
40.     bl
41.   )
42.   (vla-get-blocks (vla-get-activedocument *acad*))
43. )
44. ;;复制另外图形实体
45. (vlax-for obj (vla-get-modelspace doc)
46.   ;;如果保留扩展数据用下面这句
47.   ;;(entmake (entget (vlax-vla-object->ename obj) '("*")))
48.   ;;不保留扩展数据
49.   (entmake (entget (vlax-vla-object->ename obj)))
50. )
51. ;;回收变量
52. (vlax-release-object *acad*)
53. (vlax-release-object doc)
54. (setq bl nil
55.       *acad* nil
56.       doc nil
57. )[/pcode]

复制代码

admin

1. 使用Wblock可以干净的提取出图形实体，缺点是没有对象的图层、字体、图块丢失了！
2. 另外楼主的复制最好都采用CopyObjects方法，修改如下:
3. [pcode=lisp,true](setq *acad* (vlax-get-acad-object)
4.       doc    (vla-item (vla-get-documents *acad*) 0)
5. )
6. (defun itemsall (coll / l)
7.   (vlax-for a coll (setq l (cons a l)))
8.   (reverse l)
9.   )
10. ;;复制图层、
11. (vlax-invoke doc  'CopyObjects (itemsall (vla-get-layers doc)) (vla-get-layers (vla-get-ActiveDocument *acad*)))
12. ;;复制另外图形字体
13. (vlax-invoke doc  'CopyObjects (itemsall (vla-get-textstyles doc)) (vla-get-textstyles (vla-get-ActiveDocument *acad*)))
14. (setq l nil)
15. ;;复制块定义
16. (vlax-invoke
17.   Doc
18.   'CopyObjects
19.   (vlax-for blk (vla-get-blocks Doc)
20.     (if (/= :vlax-true (vla-get-islayout blk))
21.       (setq l (cons blk l))
22.       l
23.       )
24.     )
25.   (vla-get-blocks (vla-get-ActiveDocument *acad*))
26. )
27. ;;复制线型
28. (vlax-invoke doc  'CopyObjects (itemsall (vla-get-Linetypes doc)) (vla-get-Linetypes (vla-get-ActiveDocument *acad*)))
29. ;;复制实体
30. (vlax-invoke doc  'CopyObjects (itemsall (vla-get-ModelSpace doc)) (vla-get-ModelSpace (vla-get-ActiveDocument *acad*)))
31. [/pcode]
32. 还可以采用ObjectDBX方法，根本无需打开源文件，直接复制实体、图层、块等等！
33. [pcode=lisp,true]
34. (setq *acad* (vlax-get-acad-object)
35.       DBXDoc (vla-GetInterfaceObject
36.                *acad*
37.                (if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
38.                  "ObjectDBX.AxDbDocument"
39.                  (strcat "ObjectDBX.AxDbDocument." (itoa acVer))
40.                  )
41.                )
43.       )
44. (defun itemsall (coll / l)
45.   (vlax-for a coll (setq l (cons a l)))
46.   (reverse l)
47.   )
48. (vla-open DBXDoc (getfiled "" "" "dwg" 4))
49. ;;复制图层、
50. (vlax-invoke DBXDoc  'CopyObjects (itemsall (vla-get-layers DBXDoc)) (vla-get-layers (vla-get-ActiveDocument *acad*)))
51. ;;复制另外图形字体
52. (vlax-invoke DBXDoc  'CopyObjects (itemsall (vla-get-textstyles DBXDoc)) (vla-get-textstyles (vla-get-ActiveDocument *acad*)))
53. (setq l nil)
54. ;;复制块定义
55. (vlax-invoke
56.   DBXDoc
57.   'CopyObjects
58.   (vlax-for blk (vla-get-blocks DBXDoc)
59.     (if (/= :vlax-true (vla-get-islayout blk))
60.       (setq l (cons blk l))
61.       l
62.       )
63.     )
64.   (vla-get-blocks (vla-get-ActiveDocument *acad*))
65. )
67. ;;复制线型
68. (vlax-invoke DBXDoc  'CopyObjects (itemsall (vla-get-Linetypes DBXDoc)) (vla-get-Linetypes (vla-get-ActiveDocument *acad*)))
69. ;;复制实体
70. (vlax-invoke DBXDoc  'CopyObjects (itemsall (vla-get-ModelSpace DBXDoc)) (vla-get-ModelSpace (vla-get-ActiveDocument *acad*)))[/pcode]

复制代码