[编程交流] 需要找到所有包含的DWG

;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;
;;                                                                               ;;
;;                                                                               ;;
;;                       --=={  ObjectDBX Base Program  }==--                    ;;
;;                                                                               ;;
;;  Provides a shell through which a LISP may operate on multiple drawings in a  ;;
;;  folder/sub-folders.                                                          ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, January 2010. All Rights Reserved.                ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;  ARGUMENTS:                                                                   ;;
;;                                                                               ;;
;;  foo  ~  a function taking a single argument (the Document Object), and       ;;
;;          following the 'rules' of ObjectDBX:                                  ;;
;;                                                                               ;;
;;            - No SelectionSets               (ssget,ssname etc.)               ;;
;;            - No Command calls                                                 ;;
;;            - No *Ent Methods                (entget,entmod etc.)              ;;
;;            - No Access to System Variables  (vla-Set/GetVariable, etc)        ;;
;;                                                                               ;;
;;  dwgLst  ~  [Optional]  A list of dwg filepaths to process, if nil, program   ;;
;;                         will display BrowseForFolder dialog.                  ;;
;;                                                                               ;;
;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
;;                                                                               ;;
;;;¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,;;;
;;;ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,ø¤º°`°º¤ø,¸¸,¤º°`°º¤;;;
(defun Mac-ODBX (foo dwgLst / *error* ObjRelease Get_Subs DirDialog ObjectDBXDocument
                             DBX DBXDOC DOCLST DWGLST ERR FILE FILEPATH FLAG FOLDER PATH RESULT SUBS)
 (vl-load-com)
 (setq *acad (cond (*acad) ((vlax-get-acad-object)))
       *adoc (cond (*adoc) ((vla-get-ActiveDocument *acad))))
 
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 (defun *error* (msg)
   (ObjRelease (list dbx dbxdoc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 (defun ObjRelease (lst)
   (mapcar
     (function
       (lambda (x)
         (if (and (eq (type x) 'VLA-OBJECT)
                  (not (vlax-object-released-p x)))
           (vl-catch-all-apply
             (function vlax-release-object) (list x))))) lst))
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 (defun Get_Subs (folder / file) ;; CAB
   (mapcar
     (function
       (lambda (x) (setq file (strcat folder "\" x))
                   (cons file (apply (function append) (get_subs file)))))
       (cddr (vl-directory-files folder nil -1))))
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 
 (defun DirDialog (msg dir flag / Shell Fold Path)
   ; Lee Mac  ~ 07.06.09
   (setq *acad (cond (*acad) ((vlax-get-acad-object))))
   (setq Shell (vla-getInterfaceObject *acad "Shell.Application")
         Fold  (vlax-invoke-method Shell 'BrowseForFolder
                 (vla-get-HWND *acad) msg flag dir))
   (vlax-release-object Shell)
   (if Fold
     (progn
       (setq Path (vlax-get-property
                    (vlax-get-property Fold 'Self) 'Path))
       (vlax-release-object Fold)
       (and (= "\" (substr Path (strlen Path)))
            (setq Path (substr Path 1 (1- (strlen Path)))))))
   
   Path)
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 (defun ObjectDBXDocument (/ acVer)
   (setq *acad (cond (*acad) ((vlax-get-acad-object))))
   
   (vla-GetInterfaceObject *acad
     (if (< (setq acVer (atoi (getvar "ACADVER"))) 16) "ObjectDBX.AxDbDocument"
       (strcat "ObjectDBX.AxDbDocument." (itoa acVer)))))
 ;;=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=;;
 (if (setq dwgLst
       (cond (dwgLst)
             (  (setq Path (DirDialog "Select Directory to Process" nil 0))
                (initget "Yes No")
                (setq subs (cond ((getkword "\nProcess SubDirectories? <Yes> : ")) ("Yes")))
                (apply (function append)
                       (vl-remove 'nil
                         (mapcar
                           (function
                             (lambda (Filepath)
                               (mapcar
                                 (function
                                   (lambda (Filename)
                                     (strcat Filepath "\" Filename)))
                                 (vl-directory-files Filepath "*.dwg" 1))))
                           (append (list Path)
                                   (apply (function append)
                                          (if (= "Yes" subs) (Get_Subs Path))))))))))
   (progn
     (vlax-for doc (vla-get-Documents *acad)
       (setq DocLst
         (cons
           (cons
             (strcase
               (vla-get-fullname doc)) doc) DocLst)))
     (setq dbxdoc (ObjectDBXDocument))
     (foreach dwg dwgLst        
       (setq flag (and (setq dbx (cdr (assoc (strcase dwg) DocLst)))))
       (and (not flag)
            (setq Err (vl-catch-all-apply
                        (function vla-open) (list dbxdoc dwg)) dbx dbxdoc))
       (if (or flag (not (vl-catch-all-error-p Err)))
         (setq Result (cons (cons dwg ((eval foo) dbx)) Result))
         (princ (strcat "\n** Error Opening File: " (vl-filename-base dwg)  ".dwg **"))))))
 (ObjRelease (list dbx dbxdoc))
Result)

;; Test Function
(defun c:test (/ searchterm)
 (setq searchterm "M7 LUBE PUMP")
 (print
   (Mac-ODBX
     '(lambda (document / i) (setq i 0)
        
        (vlax-for lay (vla-get-layouts document)
          
          (vlax-for obj (vla-get-block lay)
            (if (and (eq "AcDbBlockReference"
                         (vla-get-Objectname obj))
                     (eq :vlax-true (vla-get-hasAttributes obj)))
              (foreach att (append (vlax-invoke obj 'GetAttributes)
                                   (vlax-invoke obj 'GetConstantAttributes))
                
                (if (eq searchterm (vla-get-TextString att))
                  
                  (setq i (1+ i)))))))
        i)
     nil))
 (princ))