批量删除多余布局

hsx778899

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

2. (defun BatchProcessLayouts (directory includeSubDirs / doc doclst dwg layouts layoutname files)
   
3.   ;; 获取目录下的所有图纸文件，包括子目录
   
4.   (defun GetAllDWGFiles (Dir Subs / _GetSubFolders)
   
5.     (defun _GetSubFolders (folder)
   
6.       (apply 'append
   
7.              (mapcar
   
8.                (function
   
9.                  (lambda (f)
   
10.                    (cons (strcat folder "\" f) (_GetSubFolders (strcat folder "\" f)))) )
    
11.                (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))) )
    
12.     )
    
13.     (apply 'append
    
14.            (mapcar
    
15.              (function
    
16.                (lambda (filepath)
    
17.                  (mapcar
    
18.                    (function (lambda (filename) (strcat filepath "\" filename)))
    
19.                    (vl-directory-files filepath "*.dwg" 1)) ) )
    
20.              (cons Dir (if Subs (_GetSubFolders Dir)))) )
    
21.   )
    
22. 
    
23.   ;; 删除符合条件的Layout
    
24.   (defun DeleteMatchingLayouts (layouts)
    
25.     (vlax-for lout layouts
    
26.       (setq layoutname (vla-get-name lout))
    
27.       ;; 匹配条件并删除符合的Layout
    
28.       (if (or (wcmatch layoutname "A4横")
    
29.               (wcmatch layoutname "A4竖")
    
30.               (wcmatch layoutname "A3横")
    
31.               (wcmatch layoutname "A3坚"))
    
32.         (progn
    
33.           (princ (strcat "\nDeleting layout: " layoutname))
    
34.           (vla-delete lout)
    
35.         )
    
36.       )
    
37.     )
    
38.   )
    
39. 
    
40.   ;; 遍历打开的文件或者指定目录下的文件
    
41.   (setq files (if directory (GetAllDWGFiles directory includeSubDirs) nil))
    
42. 
    
43.   ;; 如果有文件列表，则打开并遍历这些文件
    
44.   (if files
    
45.     (foreach dwgfile files
    
46.       ;; 打开图纸文件
    
47.       (setq doc (vla-open (vla-get-Documents (vlax-get-acad-object)) dwgfile))
    
48.       (if doc
    
49.         (progn
    
50.           (princ (strcat "\nProcessing file: " dwgfile))
    
51.           ;; 获取该图纸的Layouts集合
    
52.           (setq layouts (vla-get-Layouts doc))
    
53.           ;; 删除符合条件的Layouts
    
54.           (DeleteMatchingLayouts layouts)
    
55.           ;; 保存并关闭图纸
    
56.           (vla-save doc)
    
57.           (vla-close doc)
    
58.         )
    
59.       )
    
60.     )
    
61.     ;; 否则，处理所有已打开的图纸
    
62.     (vlax-for doc (vla-get-Documents (vlax-get-acad-object))
    
63.       (princ (strcat "\nProcessing open document: " (vla-get-fullname doc)))
    
64.       ;; 获取该图纸的Layouts集合
    
65.       (setq layouts (vla-get-Layouts doc))
    
66.       ;; 删除符合条件的Layouts
    
67.       (DeleteMatchingLayouts layouts)
    
68.       ;; 保存打开的图纸
    
69.       (vla-save doc)
    
70.     )
    
71.   )
    
72.   (princ "\nBatch operation completed.")
    
73. )
    
74. 
    
75. (defun c:BatchDeleteLayouts (/ directory includeSubDirs)
    
76.   ;; 提示用户选择是否使用当前目录或包含子目录
    
77.   (setq directory (getstring "\nEnter directory path (or leave blank for current drawings): "))
    
78.   (if (/= directory "")
    
79.     (setq includeSubDirs (getint "\nInclude subdirectories? (1 for Yes, 0 for No): "))
    
80.   )
    
81.   ;; 调用批量处理函数
    
82.   (BatchProcessLayouts directory (= includeSubDirs 1))
    
83. )
    

(defun BatchProcessLayouts (directory includeSubDirs / doc doclst dwg layouts layoutname files)<br />   ;; 获取目录下的所有图纸文件，包括子目录<br />   (defun GetAllDWGFiles (Dir Subs / _GetSubFolders)<br />     (defun _GetSubFolders (folder)<br />       (apply 'append<br />              (mapcar<br />                (function<br />                  (lambda (f)<br />                    (cons (strcat folder "\" f) (_GetSubFolders (strcat folder "\" f)))) )<br />                (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))) )<br />     )<br />     (apply 'append<br />            (mapcar<br />              (function<br />                (lambda (filepath)<br />                  (mapcar<br />                    (function (lambda (filename) (strcat filepath "\" filename)))<br />                    (vl-directory-files filepath "*.dwg" 1)) ) )<br />              (cons Dir (if Subs (_GetSubFolders Dir)))) )<br />   )<br /> <br />   ;; 删除符合条件的Layout<br />   (defun DeleteMatchingLayouts (layouts)<br />     (vlax-for lout layouts<br />       (setq layoutname (vla-get-name lout))<br />       ;; 匹配条件并删除符合的Layout<br />       (if (or (wcmatch layoutname "A4横")<br />               (wcmatch layoutname "A4竖")<br />               (wcmatch layoutname "A3横")<br />               (wcmatch layoutname "A3坚"))<br />         (progn<br />           (princ (strcat "\nDeleting layout: " layoutname))<br />           (vla-delete lout)<br />         )<br />       )<br />     )<br />   )<br /> <br />   ;; 遍历打开的文件或者指定目录下的文件<br />   (setq files (if directory (GetAllDWGFiles directory includeSubDirs) nil))<br /> <br />   ;; 如果有文件列表，则打开并遍历这些文件<br />   (if files<br />     (foreach dwgfile files<br />       ;; 打开图纸文件<br />       (setq doc (vla-open (vla-get-Documents (vlax-get-acad-object)) dwgfile))<br />       (if doc<br />         (progn<br />           (princ (strcat "\nProcessing file: " dwgfile))<br />           ;; 获取该图纸的Layouts集合<br />           (setq layouts (vla-get-Layouts doc))<br />           ;; 删除符合条件的Layouts<br />           (DeleteMatchingLayouts layouts)<br />           ;; 保存并关闭图纸<br />           (vla-save doc)<br />           (vla-close doc)<br />         )<br />       )<br />     )<br />     ;; 否则，处理所有已打开的图纸<br />     (vlax-for doc (vla-get-Documents (vlax-get-acad-object))<br />       (princ (strcat "\nProcessing open document: " (vla-get-fullname doc)))<br />       ;; 获取该图纸的Layouts集合<br />       (setq layouts (vla-get-Layouts doc))<br />       ;; 删除符合条件的Layouts<br />       (DeleteMatchingLayouts layouts)<br />       ;; 保存打开的图纸<br />       (vla-save doc)<br />     )<br />   )<br />   (princ "\nBatch operation completed.")<br /> )<br /> <br /> (defun c:BatchDeleteLayouts (/ directory includeSubDirs)<br />   ;; 提示用户选择是否使用当前目录或包含子目录<br />   (setq directory (getstring "\nEnter directory path (or leave blank for current drawings): "))<br />   (if (/= directory "")<br />     (setq includeSubDirs (getint "\nInclude subdirectories? (1 for Yes, 0 for No): "))<br />   )<br />   ;; 调用批量处理函数<br />   (BatchProcessLayouts directory (= includeSubDirs 1))<br /> )<br />

交流学习

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

hsx778899

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

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

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

交流学习

批量删除布局，要把布局名称写上去，但每张图纸布局名称
不同