全面的给你图形减肥的工具

Lispboy

贴个LEE-MAC的清理图形的代码。全面的给你图形减肥。

[pcode=lisp,true]
(defun c:cleandwg ( / *error* _effectivename bkc cmd doc ext flg lck lst lyc )

    ;; Error Handler
    (defun *error* ( m )
        ;; Relock Layers
        (foreach lay lck
            (if (not (vlax-erased-p lay))
                (vla-put-lock lay :vlax-true)
            )
        )
        ;; Reset CMDECHO
        (if (= 'int (type cmd))
            (setvar 'cmdecho cmd)
        )
        ;; Print critical errors
        (if (not (wcmatch (strcase m t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " m))
        )
        (princ)
    )

    ;; Function to return block effective name
    (defun _effectivename ( obj )
        (if (vlax-property-available-p obj 'effectivename)
            (vla-get-effectivename obj)
            (vla-get-name obj)
        )
    )

    (setq doc (vla-get-activedocument (vlax-get-acad-object))
          lyc (vla-get-layers doc)
          bkc (vla-get-blocks doc)
          cmd (getvar 'cmdecho)
    )
    ;; Unlock all layers
    (vlax-for lay lyc
        (if (= :vlax-true (vla-get-lock lay))
            (progn
                (setq lck (cons lay lck))
                (vla-put-lock lay :vlax-false)
            )
        )
    )

    ;; Remove Anonymous Groups
    (vlax-for grp (vla-get-groups doc)
        (if (wcmatch (vla-get-name grp) "`**")
            (vl-catch-all-apply 'vla-delete (list grp))
        )
    )

    ;; Detect empty block definitions
    (vlax-for blk bkc
        (if
            (and
                (= :vlax-false (vla-get-isxref blk))
                (= :vlax-false (vla-get-islayout blk))
            )
            (progn
                (vlax-for obj blk (setq flg t))
                (if (null flg)
                    (setq lst (cons (strcase (vla-get-name blk)) lst))
                )
                (setq flg nil)
            )
        )
    )
    ;; Remove all references of empty definitions
    (vlax-for blk bkc
        (vlax-for obj blk
            (if
                (and
                    (= "AcDbBlockReference" (vla-get-objectname obj))
                    (member (strcase (_effectivename obj)) lst)
                )
                (vl-catch-all-apply 'vla-delete (list obj))
            )
        )
    )
    ;; Remove empty block definitions
    (foreach blk lst
        (vl-catch-all-apply 'vla-delete (list (vla-item bkc blk)))
    )

    ;; Remove Layer Property & Group Filters
    (if
        (and
            (= :vlax-true (vla-get-hasextensiondictionary lyc))
            (setq ext (vla-getextensiondictionary lyc))
        )
        (foreach dic '("ACLYDICTIONARY" "ACAD_LAYERFILTERS")
             (vl-catch-all-apply 'vla-remove (list ext dic))
        )
    )   

    ;; Turn off command echo
    (setvar 'cmdecho 0)

    ;; Remove unused scales
    (command "_.-scalelistedit" "_D" "*" "_E")

    ;; Purge All
    (repeat 3 (command "_.-purge" "_A" "*" "_N"))

    ;; Reset command echo
    (setvar 'cmdecho cmd)

    ;; Relock Layers
    (foreach lay lck
        (if (not (vlax-erased-p lay))
            (vla-put-lock lay :vlax-true)
        )
    )

    ;; Exit cleanly
    (princ)
)
(vl-load-com) (princ)

[/pcode]

ww822

其实就是PURGE命令

Lispboy

ww822 发表于 2013-5-24 11:34
其实就是PURGE命令

绝对不止。看过代码了吗？

Free-Lancer

还不够彻底来自: Android客户端

牢固

高版本的scalelist很占内存！很多人习惯在编辑图时采用Crtl+C,Crtl+Paste，这样每复制一次，CAD就要把ScaleList复制一次，经过无数次编辑后，CAD图变得庞大无比，其实就是ScaleList搞得怪！其他词典类数据都不建议删除！

Lispboy

Free-Lancer 发表于 2013-5-24 11:53
还不够彻底

还有更好的吗？

tjuzkj

TOTAL PURGE，这个也不错

Free-Lancer

造成DWG垃圾的数据可能有多种，空组、空字、零长度线、未引用Blockdef、图层过滤器，最烦的词典、某些代理、Xrecord、数据错误等等

Lispboy

Free-Lancer 发表于 2013-5-24 16:20
造成DWG垃圾的数据可能有多种，空组、空字、零长度线、未引用Blockdef、图层过滤器，最烦的词典、某些代理 ...

有对这些进行处理的代码吗？

Free-Lancer

14的purge可以清理空字，零长度线，空组，低版的不知道了来自: Android客户端

Lispboy

Free-Lancer 发表于 2013-5-24 18:14
14的purge可以清理空字，零长度线，空组，低版的不知道了

14是啥，ACAD R14版本？

lgttblue

顶下楼主
:lol

Free-Lancer

Lispboy 发表于 2013-5-24 18:43
14是啥，ACAD R14版本？

呵呵，2014

ysq101

好东东。。支持

fjb54007

正需要，谢谢楼主分享