hsx778899 发表于 2024-10-21 16:24:55

批量删除多余布局

这个代码使用的是 AutoCAD ActiveX Automation 方法，下面分享给大家，本想用效率高点的ObjectDBX 方法无奈没能成功，贴子在这里希望高手帮忙解决
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=191375&highlight=ObjectDBX%2B%C9%BE%B3%FD

(defun BatchProcessLayouts (directory includeSubDirs / doc doclst dwg layouts layoutname files)
;; 获取目录下的所有图纸文件，包括子目录
(defun GetAllDWGFiles (Dir Subs / _GetSubFolders)
    (defun _GetSubFolders (folder)
      (apply 'append
             (mapcar
               (function
               (lambda (f)
                   (cons (strcat folder "\\" f) (_GetSubFolders (strcat folder "\\" f)))) )
               (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))) )
    )
    (apply 'append
         (mapcar
             (function
               (lambda (filepath)
               (mapcar
                   (function (lambda (filename) (strcat filepath "\\" filename)))
                   (vl-directory-files filepath "*.dwg" 1)) ) )
             (cons Dir (if Subs (_GetSubFolders Dir)))) )
)

;; 删除符合条件的Layout
(defun DeleteMatchingLayouts (layouts)
    (vlax-for lout layouts
      (setq layoutname (vla-get-name lout))
      ;; 匹配条件并删除符合的Layout
      (if (or (wcmatch layoutname "A4横")
            (wcmatch layoutname "A4竖")
            (wcmatch layoutname "A3横")
            (wcmatch layoutname "A3坚"))
      (progn
          (princ (strcat "\nDeleting layout: " layoutname))
          (vla-delete lout)
      )
      )
    )
)

;; 遍历打开的文件或者指定目录下的文件
(setq files (if directory (GetAllDWGFiles directory includeSubDirs) nil))

;; 如果有文件列表，则打开并遍历这些文件
(if files
    (foreach dwgfile files
      ;; 打开图纸文件
      (setq doc (vla-open (vla-get-Documents (vlax-get-acad-object)) dwgfile))
      (if doc
      (progn
          (princ (strcat "\nProcessing file: " dwgfile))
          ;; 获取该图纸的Layouts集合
          (setq layouts (vla-get-Layouts doc))
          ;; 删除符合条件的Layouts
          (DeleteMatchingLayouts layouts)
          ;; 保存并关闭图纸
          (vla-save doc)
          (vla-close doc)
      )
      )
    )
    ;; 否则，处理所有已打开的图纸
    (vlax-for doc (vla-get-Documents (vlax-get-acad-object))
      (princ (strcat "\nProcessing open document: " (vla-get-fullname doc)))
      ;; 获取该图纸的Layouts集合
      (setq layouts (vla-get-Layouts doc))
      ;; 删除符合条件的Layouts
      (DeleteMatchingLayouts layouts)
      ;; 保存打开的图纸
      (vla-save doc)
    )
)
(princ "\nBatch operation completed.")
)

(defun c:BatchDeleteLayouts (/ directory includeSubDirs)
;; 提示用户选择是否使用当前目录或包含子目录
(setq directory (getstring "\nEnter directory path (or leave blank for current drawings): "))
(if (/= directory "")
    (setq includeSubDirs (getint "\nInclude subdirectories? (1 for Yes, 0 for No): "))
)
;; 调用批量处理函数
(BatchProcessLayouts directory (= includeSubDirs 1))
)


交流学习 发表于 2024-10-21 16:47:31

这个怎么用，两个布局没有删除

hsx778899 发表于 2024-10-21 16:59:03

交流学习 发表于 2024-10-21 16:47
这个怎么用，两个布局没有删除

      ;; 匹配条件并删除符合的Layout
      (if (or (wcmatch layoutname "A4横")
            (wcmatch layoutname "A4竖")
            (wcmatch layoutname "A3横")
            (wcmatch layoutname "A3坚"))

修改此处要删除的布局名称

交流学习 发表于 2024-10-22 14:46:55

批量删除布局，要把布局名称写上去，但每张图纸布局名称
不同
页: [1]
查看完整版本: 批量删除多余布局