[编程交流] 跨多个

(vl-load-com)
;;; Gets the ODBX object for use on external DWGs
(defun DBX:GetODBX-Object  (/ classname Register)
 (defun Register  (classname filename / server acver)
   (cond
     ((not (and classname filename))
      (Register (strcat "ObjectDBX.AxDbDocument." (itoa (setq acver (atoi (getvar 'ACadVer)))))
                (strcat "AxDb" (itoa acver) ".dll")))
     ((vl-registry-read (strcat "HKEY_CLASSES_ROOT\" classname "\\CLSID")) classname)
     ((and (setq server (findfile filename))
           (startapp "regsvr32.exe" (strcat "/s "" dll """))
           (vl-registry-read (strcat "HKEY_CLASSES_ROOT\" classname "\\CLSID")))
      classname)))
 (if (setq classname (Register nil nil))
   (vla-getinterfaceobject (vlax-get-acad-object) classname)))
;;; Asks user to choose a folder and returns the paths to all DWGs in that folder
(defun BLC:GetDWGs  (/ path)
 (if (setq path (getfiled "\nSelect File from Directory to Read: " "" "dwg" 0))
   (mapcar (function (lambda (filename) (strcat path "\" filename)))
           (vl-directory-files (setq path (vl-filename-directory path)) "*.dwg" 1))))
;;; Runs a function on each DWG in the list, passing a Document object to the function
(defun BLC:RunDWGs  (dwgList code / odbx result)
 (setq result
        (cond ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'DBX:GetODBX-Object))) nil)
              (t (mapcar
                   (function
                     (lambda (path / result)
                       (cond ((vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list odbx path))) nil)
                             (t (setq result (vl-catch-all-apply code (list odbx)))
                                (vl-catch-all-apply 'vla-Close (list odbx))
                                (cons path result)))))
                   dwgList))))
 (cond (odbx (vl-catch-all-apply 'vlax-release-object (list odbx))))
 result)
;;; Asks user to pick an object & a folder of DWG's to set all their corresponding layers
;;; to the same colour as the object's layer
(defun c:BatchLayCol (/ ent lay col files DoChange)
 (if (and (setq ent (entsel))
          (setq files (BLC:GetDWGs))
          (setq ent (vlax-ename->vla-object (car ent)))
          (setq lay (vla-Item (vla-get-Layers (vla-get-Document ent)) (vla-get-Layer ent)))
          (setq col (vla-get-Color lay)))
   (progn (defun DoChange (doc / )
            (vla-put-Color (vla-Item (vla-get-Layers doc) (vla-get-Name lay)) col)
            (vla-SaveAs doc (vla-get-Name doc))
            "done")
          (foreach result (BLC:RunDWGs files 'DoChange)
            (princ "\n")
            (princ (car result))
            (princ "\t")
            (princ (cond ((vl-catch-all-error-p (cdr result))
                          (cond ((wcmatch (strcase (setq result (vl-catch-all-error-message (cdr result)))) "*DESCRIPTION WAS NOT PROVIDED*")
                                 "File read-only or opened by someone else.")
                                (result)))
                         (t (cdr result)))))))
 (command "_TextScr")
 (princ))