（XD::VLA:ODBX）处理外部DWG通用接口函数(VLISP版）

newer · 发表于 2021-2-3 14:31:07

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(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)
)
)
)

(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)
)

(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) 
)

zteykmgscqh · 发表于 2021-7-27 15:31:35

如此精彩源码函数，必须点赞！

账号		自动登录	找回密码
密码			立即注册

[VL对象] （XD::VLA:ODBX）处理外部DWG通用接口函数(VLISP版）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分