另类Purge
另类Purge偶尔遇到一种特别大的DWG，上百兆了，打开后看着也没有多少Entity，用Purge显示没有可清的东西，经过分析Dwg中附加的信息太多，可能包括Xdat、Dict、Xrecord等等，如果一个个处理可能要逐一分析，太麻烦，下面用简单的步骤和简单的几个语句实现另类“Purge”
1 打开Dwg，这里太大的DWG可能在32bit系统和CAD会很慢，为了最简单处理，确保CAD仅有这一个文档打开
2 文件-〉新建一个文档，用默认设置
3 打开Vlisp编辑器
4 把下面几句粘贴进去，加载，慢慢等待，Ok
5 保存图形，前后对比看看能瘦身多少
说明：
a：字体样式复制是必须的，否则可能无法显示部分字体
b:图块复制也是必须的，否则Insert无法生成
c：图层复制非必须，复制仅是为了保持原汁原味，否则可能都是一种白色
声明：本语句处理有风险，后果自负！
(setq *acad* (vlax-get-acad-object)
doc (vla-item (vla-get-documents *acad*) 0)
)
;;复制另外图形图层
(vlax-for lay (vla-get-layers doc)
(entmake (entget (vlax-vla-object->ename lay)))
)
;;复制另外图形字体
(vlax-for sty (vla-get-textstyles doc)
(entmake (entget (vlax-vla-object->ename sty)))
)
;;构造另外图块定义
(vlax-for obj (vla-get-blocks doc)
(if (not (wcmatch (strcase (vla-get-name obj)) "*SPACE*"))
(setq bl (cons obj bl))
)
)
;;拷贝另外图块定义
(vla-CopyObjects
doc
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
(cons 0 (1- (length bl)))
)
bl
)
(vla-get-blocks (vla-get-activedocument *acad*))
)
;;复制另外图形实体
(vlax-for obj (vla-get-modelspace doc)
;;如果保留扩展数据用下面这句
;;(entmake (entget (vlax-vla-object->ename obj) '("*")))
;;不保留扩展数据
(entmake (entget (vlax-vla-object->ename obj)))
)
;;回收变量
(vlax-release-object *acad*)
(vlax-release-object doc)
(setq bl nil
*acad* nil
doc nil
) 使用Wblock可以干净的提取出图形实体，缺点是没有对象的图层、字体、图块丢失了！
另外楼主的复制最好都采用CopyObjects方法，修改如下:
(setq *acad* (vlax-get-acad-object)
doc (vla-item (vla-get-documents *acad*) 0)
)
(defun itemsall (coll / l)
(vlax-for a coll (setq l (cons a l)))
(reverse l)
)
;;复制图层、
(vlax-invoke doc'CopyObjects (itemsall (vla-get-layers doc)) (vla-get-layers (vla-get-ActiveDocument *acad*)))
;;复制另外图形字体
(vlax-invoke doc'CopyObjects (itemsall (vla-get-textstyles doc)) (vla-get-textstyles (vla-get-ActiveDocument *acad*)))
(setq l nil)
;;复制块定义
(vlax-invoke
Doc
'CopyObjects
(vlax-for blk (vla-get-blocks Doc)
(if (/= :vlax-true (vla-get-islayout blk))
(setq l (cons blk l))
l
)
)
(vla-get-blocks (vla-get-ActiveDocument *acad*))
)
;;复制线型
(vlax-invoke doc'CopyObjects (itemsall (vla-get-Linetypes doc)) (vla-get-Linetypes (vla-get-ActiveDocument *acad*)))
;;复制实体
(vlax-invoke doc'CopyObjects (itemsall (vla-get-ModelSpace doc)) (vla-get-ModelSpace (vla-get-ActiveDocument *acad*)))
还可以采用ObjectDBX方法，根本无需打开源文件，直接复制实体、图层、块等等！
(setq *acad* (vlax-get-acad-object)
DBXDoc (vla-GetInterfaceObject
*acad*
(if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acVer))
)
)
)
(defun itemsall (coll / l)
(vlax-for a coll (setq l (cons a l)))
(reverse l)
)
(vla-open DBXDoc (getfiled "" "" "dwg" 4))
;;复制图层、
(vlax-invoke DBXDoc'CopyObjects (itemsall (vla-get-layers DBXDoc)) (vla-get-layers (vla-get-ActiveDocument *acad*)))
;;复制另外图形字体
(vlax-invoke DBXDoc'CopyObjects (itemsall (vla-get-textstyles DBXDoc)) (vla-get-textstyles (vla-get-ActiveDocument *acad*)))
(setq l nil)
;;复制块定义
(vlax-invoke
DBXDoc
'CopyObjects
(vlax-for blk (vla-get-blocks DBXDoc)
(if (/= :vlax-true (vla-get-islayout blk))
(setq l (cons blk l))
l
)
)
(vla-get-blocks (vla-get-ActiveDocument *acad*))
)
;;复制线型
(vlax-invoke DBXDoc'CopyObjects (itemsall (vla-get-Linetypes DBXDoc)) (vla-get-Linetypes (vla-get-ActiveDocument *acad*)))
;;复制实体
(vlax-invoke DBXDoc'CopyObjects (itemsall (vla-get-ModelSpace DBXDoc)) (vla-get-ModelSpace (vla-get-ActiveDocument *acad*)))
页:
[1]