（XD::VLA:ODBX）处理外部DWG通用接口函数(VLISP版）
(defun XD::VLA:ODBX
(fun lst sav / *error* app dbx dir doc dwl err rtn vrs)
(defun *error* (msg)
(if (and
(= 'vla-object (type dbx))
(not (vlax-object-released-p dbx))
)
(vlax-release-object dbx)
)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(cond
((not (or
lst
(and
(setq dir (XD::SYSTEM:browseforfolder
"Select Folder of Drawings to Process"
nil
512
)
)
(setq lst (mapcar
'(lambda (x)
(strcat dir "\\" x)
)
(vl-directory-files dir "*.dwg" 1)
)
)
)
)
)
nil
)
((progn
(setq dbx (vl-catch-all-apply
'vla-getinterfaceobject
(list
(setq app
(vlax-get-acad-object)
)
(if
(<
(setq vrs
(atoi
(getvar 'acadver)
)
)
16
)
"objectdbx.axdbdocument"
(strcat "objectdbx.axdbdocument."
(itoa vrs)
)
)
)
)
)
(or
(null dbx)
(vl-catch-all-error-p dbx)
)
)
(prompt "\nUnable to interface with ObjectDBX.")
)
(t
(setq _savever (vla-get-saveastype
(vla-get-opensave
(vla-get-preferences app)
)
)
)
(vlax-for doc (vla-get-documents app)
(setq dwl (cons (cons
(strcase
(vla-get-fullname doc)
)
doc
)
dwl
)
)
)
(foreach dwg lst
(if (or
(setq doc (cdr (assoc (strcase dwg) dwl)))
(and
(not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-open
(list dbx dwg)
)
)
)
(setq doc dbx)
)
)
(progn
(setq rtn
(cons
(cons
dwg
(if (vl-catch-all-error-p
(setq err
(vl-catch-all-apply
fun
(list doc)
)
)
)
(prompt (strcat "\n"
dwg
"\t"
(vl-catch-all-error-message err)
)
)
err
)
)
rtn
)
)
(if sav
(progn
(if (vl-catch-all-error-p
(setq err
(vl-catch-all-apply
'vla-saveas
(list doc dwg)
)
)
)
(princ (strcat "\nError save file: "
(vl-filename-base dwg)
".dwg"
)
)
err
)
)
)
)
(princ (strcat "\nError opening file: "
(vl-filename-base dwg)
".dwg"
)
)
)
)
(if (= 'vla-object (type dbx))
(vlax-release-object dbx)
)
(reverse rtn)
)
)
)
下面是处理外部DWG文件的通用框架，可以修改里面的回调函数 _remove，适合自己的需要
(defun c:tt ()
(defun _remove (doc)
(defun _print-progess (doc gap / dwg)
(setq dwg (vla-get-name doc)
dwg (strcat (vl-filename-base dwg) (vl-filename-extension dwg))
)
(princ (xd::string:tailcut (strcat "\n处理 " dwg) gap "..."))
)
(textpage)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;单文件信息打印框架
(setq num1 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(_print-progess doc 30)
(setq lst1 nil)
(vlax-for blk (vla-get-blocks doc)
(if (and (/= (vla-get-isxref blk) :vlax-true)
(/= (vla-get-islayout blk):vlax-true))
(progn
(setq lst1 (cons (vla-get-name blk) lst1))
)
)
)
(setq num (1+ num))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;单文件信息打印框架
(princ (strcat "处理了 " (itoa (length lst1)) " 图块."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun _check ()
(if (or (not xd::vla:odbx) (not (= (type xd::vla:odbx) 'SUBR)))
(progn (princ "\n请加载晓东通用LISP函数库再执行.") (exit))
t
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;主程序框架 ;
(defun _main ()
(xd::begin)
(setq num 0
fns 0
)
(xd::vla:odbx '_remove nil t)
(princ (strcat "\n\n共处理了 " (itoa num) " 个DWG文件."))
(xd::end)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;main ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(_main)
(princ)
)
如此精彩源码函数，必须点赞！{:1_20:} 自定义函数有什么要求啊
页:
[1]