批量合并图纸又快又避免同名块影响,AI编写的

f4800 · 发表于昨天 17:22

在CAD图纸里有多个布局和一个模型空间，每个布局的图框和位置基本上是一致的。

目标：
1、把多个布局合并到一个布局里
2、可选需要合并的布局数量和合并后的布局
3、是否删除旧的布局，建议默认删除
4、保持合并后的布局排版，建议横向排列，图框间距 50~100mm

是否可以用lisp语言实现这些功能

用国内免费的ai 测试了几个运行中均出现错误

f4800 · 发表于昨天 18:08

ai的代码还有不少问题排版还是有问题

;;; MergeLayouts.lsp
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口）
;;; 兼容 AutoCAD 2012 – 2024 标准版（无需 DCL，无 vl-choice-list）
(vl-load-com)
; 快捷命令
(defun c:tt2 () (c:MergeLayouts))
(defun c:tr2 () (c:MergeLayouts))
(princ "\n命令已加载，输入 SIDECUT 或 tt2 启动")
(princ)
;;; MergeLayouts.lsp
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口）
;;; 兼容 AutoCAD 2012 – 2024 标准版 | 无 DCL | 无第三方依赖
;;; MergeLayouts.lsp
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口）
;;; 兼容 AutoCAD 2012 – 2024 标准版 | 无 DCL | 自动创建视口
(vl-load-com)
(defun c:MergeLayouts (/ doc layouts allLayoutNames srcNames tgtName
delSrc? cols row col basePt offsetVec
entsToCopy bbox width height newInsertPt layoutObj
input indices)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq layouts (vla-get-Layouts doc))
;; 获取所有非 Model 布局名称
(setq allLayoutNames '())
(vlax-for layout layouts
(setq layName (vla-get-Name layout))
(if (/= (strcase layName) "MODEL")
(setq allLayoutNames (cons layName allLayoutNames))
)
)
(setq allLayoutNames (reverse allLayoutNames))
;; 检查布局数量
(if (< (length allLayoutNames) 2)
(progn
(alert "至少需要两个布局（不含 Model）才能合并！")
(princ)
(exit)
)
)
;; ========== 选择源布局（编号多选）==========
(princ "\n可用布局列表:")
(setq i 0)
(foreach name allLayoutNames
(princ (strcat "\n [" (itoa (setq i (1+ i))) "] " name))
)
(princ "\n\n请输入要合并的源布局编号（空格分隔，例如: 1 3 4）: ")
(setq input (getstring T))
(if (= input "") (exit))
;; 安全解析输入
(if (wcmatch (strcat " " input " ") "*[~ 0-9 ]*")
(progn
(alert "输入格式错误！\n请只输入数字，用空格分隔（如: 1 2 3）。")
(exit)
)
)
(setq indices (read (strcat "(" (vl-string-trim " " input) ")")))
(if (atom indices) (setq indices (list indices)))
(setq srcNames
(vl-remove-if-not
'(lambda (idx) (and (>= idx 1) (<= idx (length allLayoutNames))))
indices
)
)
(if (null srcNames)
(progn (alert "未选择任何有效布局！") (exit))
)
(setq srcNames
(mapcar '(lambda (i) (nth (1- i) allLayoutNames)) srcNames)
)
;; ========== 源布局选择结束 ==========
;; ========== 选择目标布局 ==========
(setq candidates (vl-remove-if '(lambda (x) (member x srcNames)) allLayoutNames))
(cond
(candidates
(princ "\n可选目标布局:")
(setq i 0)
(foreach name candidates
(princ (strcat "\n [" (itoa (setq i (1+ i))) "] " name))
)
(princ "\n\n输入目标布局编号，或直接回车新建布局: ")
(setq input (getstring T))
(if (= input "")
(setq tgtName (getstring "\n输入新布局名称 <Merged_Layout>: "))
(progn
(if (wcmatch input "*[~0-9]*")
(setq tgtName "Merged_Layout")
(progn
(setq idx (atoi input))
(if (and (>= idx 1) (<= idx (length candidates)))
(setq tgtName (nth (1- idx) candidates))
(setq tgtName "Merged_Layout")
)
)
)
)
)
)
(T
(setq tgtName (getstring "\n输入新布局名称 <Merged_Layout>: "))
)
)
(if (= tgtName "") (setq tgtName "Merged_Layout"))
;; 创建目标布局（如果不存在）
(if (not (member tgtName allLayoutNames))
(vla-Add layouts tgtName)
)
;; ✅ 关键修正：确保目标布局有活动视口
(EnsureActiveViewport tgtName)
;; 是否删除源布局？
(initget "是否")
(setq delSrc?
(= (getkword "\n是否删除源布局？[是/否] <否>: ") "是")
)
;; 清空目标布局（保留一个视口）
(ClearLayout tgtName)
;; ========== 合并处理 ==========
(setq cols 2) ; 每行布局数量
(setq row 0)
(setq col 0)
(foreach layName srcNames
(princ (strcat "\n正在处理布局: " layName))
(setq layoutObj (vla-Item layouts layName))
(setq entsToCopy (ssget "_X" (list (cons 410 layName))))
(if entsToCopy
(progn
(setq basePt (GetFrameBasePoint entsToCopy))
(if (null basePt) (setq basePt '(0.0 0.0 0.0)))
(setq bbox (GetLayoutBoundingBox entsToCopy))
(if bbox
(progn
(setq width (- (car (cadr bbox)) (car (car bbox))))
(setq height (- (cadr (cadr bbox)) (cadr (car bbox))))
)
(progn
(setq width 1189.0) ; A3 宽 (mm)
(setq height 841.0) ; A3 高 (mm)
)
)
(setq newInsertPt
(list
(+ (* col (+ width 20.0)) 10.0)
(- (* row (+ height 20.0)) 10.0)
0.0
)
)
(setq offsetVec (mapcar '- newInsertPt basePt))
(CopyAndMoveEntities entsToCopy tgtName offsetVec)
)
)
(setq col (1+ col))
(if (>= col cols) (setq col 0 row (1+ row)))
(if delSrc? (vla-Delete layoutObj))
)
(setvar "CTAB" tgtName)
(princ (strcat "\n✅ 合并完成！目标布局: " tgtName))
(princ)
)
;; ========== 确保布局有活动视口 ==========
(defun EnsureActiveViewport (layName / doc layouts)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq layouts (vla-get-Layouts doc))
;; 切换到目标布局
(setvar "CTAB" layName)
;; 检查是否存在视口
(setq hasViewport nil)
(vlax-for obj (vla-get-Block (vla-Item layouts layName))
(if (= (vla-get-ObjectName obj) "AcDbViewport")
(setq hasViewport T)
)
)
;; 如果没有视口，创建默认视口
(if (not hasViewport)
(progn
(princ (strcat "\n ⚠️ 布局 " layName " 无视口，正在创建默认视口..."))
(command "_.MVIEW" "_FIT")
;; 等待命令完成
(while (> (getvar "CMDACTIVE") 0)
(command)
)
)
)
)
;; ========== 安全获取点坐标 ==========
(defun GetPointSafe (obj prop / pt)
(setq pt (vlax-get obj prop))
(cond
((listp pt) pt)
((= (type pt) 'variant)
(vlax-safearray->list (vlax-variant-value pt))
)
(T nil)
)
)
;; ========== 获取图框块插入点 ==========
(defun GetFrameBasePoint (ss / i ent obj pt)
(setq i 0 pt nil)
(repeat (sslength ss)
(if (null pt)
(progn
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
(if (= (vla-get-ObjectName obj) "AcDbBlockReference")
(setq pt (GetPointSafe obj 'InsertionPoint))
)
)
)
(setq i (1+ i))
)
pt
)
;; ========== 获取布局包围盒 ==========
(defun GetLayoutBoundingBox (ss / minPt maxPt globalMin globalMax i ent obj)
(setq i 0 globalMin nil globalMax nil)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
(if (not (wcmatch (vla-get-ObjectName obj) "*Viewport"))
(progn
(vla-GetBoundingBox obj 'minPt 'maxPt)
(if (null globalMin)
(setq globalMin minPt globalMax maxPt)
(progn
(setq globalMin (MapMinMax globalMin minPt 'min))
(setq globalMax (MapMinMax globalMax maxPt 'max))
)
)
)
)
(setq i (1+ i))
)
(if globalMin
(list
(vlax-safearray->list globalMin)
(vlax-safearray->list globalMax)
)
)
)
;; ========== 向量 min/max ==========
(defun MapMinMax (v1 v2 op / x1 y1 z1 x2 y2 z2)
(setq x1 (vlax-safearray-get-element v1 0)
y1 (vlax-safearray-get-element v1 1)
z1 (vlax-safearray-get-element v1 2)
x2 (vlax-safearray-get-element v2 0)
y2 (vlax-safearray-get-element v2 1)
z2 (vlax-safearray-get-element v2 2)
)
(vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 2))
(list
((if (= op 'min) min max) x1 x2)
((if (= op 'min) min max) y1 y2)
((if (= op 'min) min max) z1 z2)
)
)
)
;; ========== 复制并移动实体 ==========
(defun CopyAndMoveEntities (ss tgtLayoutName offset / oldCTAB i ent obj newEnt doc)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq oldCTAB (getvar "CTAB"))
(setvar "CTAB" tgtLayoutName)
(setq i 0)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
;; 跳过主视口：保留第一个视口（由 ClearLayout 保证存在）
(if (/= (vla-get-ObjectName obj) "AcDbViewport")
(progn
(setq newEnt (vla-Copy obj))
(vla-Move newEnt (vlax-3d-point '(0 0 0)) (vlax-3d-point offset))
)
;; 视口也复制（但 ClearLayout 已清空，所以这里不会重复）
(progn
(setq newEnt (vla-Copy obj))
(vla-Move newEnt (vlax-3d-point '(0 0 0)) (vlax-3d-point offset))
)
)
(setq i (1+ i))
)
(setvar "CTAB" oldCTAB)
)
;; ========== 清空布局（保留第一个视口）==========
(defun ClearLayout (layName / oldCTAB doc layoutObj firstVP ss i ent obj)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq oldCTAB (getvar "CTAB"))
(setvar "CTAB" layName)
(setq layoutObj (vla-Item (vla-get-Layouts doc) layName))
;; 找到第一个视口（用于保留）
(setq firstVP nil)
(vlax-for obj (vla-get-Block layoutObj)
(if (and (= (vla-get-ObjectName obj) "AcDbViewport") (null firstVP))
(setq firstVP obj)
)
)
;; 删除所有实体，除了第一个视口
(setq ss (ssget "_X" (list (cons 410 layName))))
(if ss
(progn
(setq i 0)
(repeat (sslength ss)
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
(if (or (/= (vla-get-ObjectName obj) "AcDbViewport")
(/= obj firstVP))
(vla-delete obj)
)
(setq i (1+ i))
)
)
)
(setvar "CTAB" oldCTAB)
)
;; ========== 字符串工具 ==========
(defun vl-string-trim (chars str / len)
(while (and (> (strlen str) 0) (vl-position (ascii (substr str 1 1)) (vl-string->list chars)))
(setq str (substr str 2))
)
(while (and (> (strlen str) 0) (vl-position (ascii (substr str (strlen str) 1)) (vl-string->list chars)))
(setq str (substr str 1 (1- (strlen str))))
)
str
)
(defun vl-string->list (str / i lst)
(setq i 0 lst '())
(while (< i (strlen str))
(setq lst (cons (ascii (substr str (setq i (1+ i)) 1)) lst))
)
(reverse lst)
)
(princ "\n命令 MERGELAYOUTS 已加载。")
(princ "\n✅ 支持：块图框 + 多视口 + 自动创建默认视口")
(princ "\n✅ 兼容 AutoCAD 2012 – 2024 标准版")
(princ "\n📌 使用方法：输入 MERGELAYOUTS，按编号选择布局。")
(princ)

;;; MergeLayouts.lsp 
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口） 
;;; 兼容 AutoCAD 2012 – 2024 标准版（无需 DCL，无 vl-choice-list） 
 
(vl-load-com) 
; 快捷命令 
(defun c:tt2 () (c:MergeLayouts)) 
(defun c:tr2 () (c:MergeLayouts)) 
 
(princ "\n命令已加载，输入 SIDECUT 或 tt2 启动") 
(princ) 
 
;;; MergeLayouts.lsp 
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口） 
;;; 兼容 AutoCAD 2012 – 2024 标准版 | 无 DCL | 无第三方依赖 
 
;;; MergeLayouts.lsp 
;;; 功能：合并多个布局到一个布局（支持块图框 + 多视口） 
;;; 兼容 AutoCAD 2012 – 2024 标准版 | 无 DCL | 自动创建视口 
 
(vl-load-com) 
 
(defun c:MergeLayouts (/ doc layouts allLayoutNames srcNames tgtName 
                        delSrc? cols row col basePt offsetVec 
                        entsToCopy bbox width height newInsertPt layoutObj 
                        input indices) 
 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (setq layouts (vla-get-Layouts doc)) 
 
  ;; 获取所有非 Model 布局名称 
  (setq allLayoutNames '()) 
  (vlax-for layout layouts 
    (setq layName (vla-get-Name layout)) 
    (if (/= (strcase layName) "MODEL") 
      (setq allLayoutNames (cons layName allLayoutNames)) 
    ) 
  ) 
  (setq allLayoutNames (reverse allLayoutNames)) 
 
  ;; 检查布局数量 
  (if (< (length allLayoutNames) 2) 
    (progn 
      (alert "至少需要两个布局（不含 Model）才能合并！") 
      (princ) 
      (exit) 
    ) 
  ) 
 
  ;; ========== 选择源布局（编号多选）========== 
  (princ "\n可用布局列表:") 
  (setq i 0) 
  (foreach name allLayoutNames 
    (princ (strcat "\n  [" (itoa (setq i (1+ i))) "] " name)) 
  ) 
  (princ "\n\n请输入要合并的源布局编号（空格分隔，例如: 1 3 4）: ") 
  (setq input (getstring T)) 
  (if (= input "") (exit)) 
 
  ;; 安全解析输入 
  (if (wcmatch (strcat " " input " ") "*[~ 0-9 ]*") 
    (progn 
      (alert "输入格式错误！\n请只输入数字，用空格分隔（如: 1 2 3）。") 
      (exit) 
    ) 
  ) 
 
  (setq indices (read (strcat "(" (vl-string-trim " " input) ")"))) 
  (if (atom indices) (setq indices (list indices))) 
 
  (setq srcNames 
    (vl-remove-if-not 
      '(lambda (idx) (and (>= idx 1) (<= idx (length allLayoutNames)))) 
      indices 
    ) 
  ) 
  (if (null srcNames) 
    (progn (alert "未选择任何有效布局！") (exit)) 
  ) 
  (setq srcNames 
    (mapcar '(lambda (i) (nth (1- i) allLayoutNames)) srcNames) 
  ) 
  ;; ========== 源布局选择结束 ========== 
 
  ;; ========== 选择目标布局 ========== 
  (setq candidates (vl-remove-if '(lambda (x) (member x srcNames)) allLayoutNames)) 
  (cond 
    (candidates 
      (princ "\n可选目标布局:") 
      (setq i 0) 
      (foreach name candidates 
        (princ (strcat "\n  [" (itoa (setq i (1+ i))) "] " name)) 
      ) 
      (princ "\n\n输入目标布局编号，或直接回车新建布局: ") 
      (setq input (getstring T)) 
      (if (= input "") 
        (setq tgtName (getstring "\n输入新布局名称 <Merged_Layout>: ")) 
        (progn 
          (if (wcmatch input "*[~0-9]*") 
            (setq tgtName "Merged_Layout") 
            (progn 
              (setq idx (atoi input)) 
              (if (and (>= idx 1) (<= idx (length candidates))) 
                (setq tgtName (nth (1- idx) candidates)) 
                (setq tgtName "Merged_Layout") 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (T 
      (setq tgtName (getstring "\n输入新布局名称 <Merged_Layout>: ")) 
    ) 
  ) 
  (if (= tgtName "") (setq tgtName "Merged_Layout")) 
 
  ;; 创建目标布局（如果不存在） 
  (if (not (member tgtName allLayoutNames)) 
    (vla-Add layouts tgtName) 
  ) 
 
  ;; &#9989; 关键修正：确保目标布局有活动视口 
  (EnsureActiveViewport tgtName) 
 
  ;; 是否删除源布局？ 
  (initget "是 否") 
  (setq delSrc? 
    (= (getkword "\n是否删除源布局？[是/否] <否>: ") "是") 
  ) 
 
  ;; 清空目标布局（保留一个视口） 
  (ClearLayout tgtName) 
 
  ;; ========== 合并处理 ========== 
  (setq cols 2) ; 每行布局数量 
  (setq row 0) 
  (setq col 0) 
 
  (foreach layName srcNames 
    (princ (strcat "\n正在处理布局: " layName)) 
    (setq layoutObj (vla-Item layouts layName)) 
    (setq entsToCopy (ssget "_X" (list (cons 410 layName)))) 
 
    (if entsToCopy 
      (progn 
        (setq basePt (GetFrameBasePoint entsToCopy)) 
        (if (null basePt) (setq basePt '(0.0 0.0 0.0))) 
 
        (setq bbox (GetLayoutBoundingBox entsToCopy)) 
        (if bbox 
          (progn 
            (setq width (- (car (cadr bbox)) (car (car bbox)))) 
            (setq height (- (cadr (cadr bbox)) (cadr (car bbox)))) 
          ) 
          (progn 
            (setq width 1189.0) ; A3 宽 (mm) 
            (setq height 841.0) ; A3 高 (mm) 
          ) 
        ) 
 
        (setq newInsertPt 
          (list 
            (+ (* col (+ width 20.0)) 10.0) 
            (- (* row (+ height 20.0)) 10.0) 
            0.0 
          ) 
        ) 
        (setq offsetVec (mapcar '- newInsertPt basePt)) 
        (CopyAndMoveEntities entsToCopy tgtName offsetVec) 
      ) 
    ) 
 
    (setq col (1+ col)) 
    (if (>= col cols) (setq col 0 row (1+ row))) 
 
    (if delSrc? (vla-Delete layoutObj)) 
  ) 
 
  (setvar "CTAB" tgtName) 
  (princ (strcat "\n&#9989; 合并完成！目标布局: " tgtName)) 
  (princ) 
) 
 
;; ========== 确保布局有活动视口 ========== 
(defun EnsureActiveViewport (layName / doc layouts) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (setq layouts (vla-get-Layouts doc)) 
   
  ;; 切换到目标布局 
  (setvar "CTAB" layName) 
   
  ;; 检查是否存在视口 
  (setq hasViewport nil) 
  (vlax-for obj (vla-get-Block (vla-Item layouts layName)) 
    (if (= (vla-get-ObjectName obj) "AcDbViewport") 
      (setq hasViewport T) 
    ) 
  ) 
   
  ;; 如果没有视口，创建默认视口 
  (if (not hasViewport) 
    (progn 
      (princ (strcat "\n  &#9888;&#65039; 布局 " layName " 无视口，正在创建默认视口...")) 
      (command "_.MVIEW" "_FIT") 
      ;; 等待命令完成 
      (while (> (getvar "CMDACTIVE") 0) 
        (command) 
      ) 
    ) 
  ) 
) 
 
;; ========== 安全获取点坐标 ========== 
(defun GetPointSafe (obj prop / pt) 
  (setq pt (vlax-get obj prop)) 
  (cond 
    ((listp pt) pt) 
    ((= (type pt) 'variant) 
      (vlax-safearray->list (vlax-variant-value pt)) 
    ) 
    (T nil) 
  ) 
) 
 
;; ========== 获取图框块插入点 ========== 
(defun GetFrameBasePoint (ss / i ent obj pt) 
  (setq i 0 pt nil) 
  (repeat (sslength ss) 
    (if (null pt) 
      (progn 
        (setq ent (ssname ss i)) 
        (setq obj (vlax-ename->vla-object ent)) 
        (if (= (vla-get-ObjectName obj) "AcDbBlockReference") 
          (setq pt (GetPointSafe obj 'InsertionPoint)) 
        ) 
      ) 
    ) 
    (setq i (1+ i)) 
  ) 
  pt 
) 
 
;; ========== 获取布局包围盒 ========== 
(defun GetLayoutBoundingBox (ss / minPt maxPt globalMin globalMax i ent obj) 
  (setq i 0 globalMin nil globalMax nil) 
  (repeat (sslength ss) 
    (setq ent (ssname ss i)) 
    (setq obj (vlax-ename->vla-object ent)) 
    (if (not (wcmatch (vla-get-ObjectName obj) "*Viewport")) 
      (progn 
        (vla-GetBoundingBox obj 'minPt 'maxPt) 
        (if (null globalMin) 
          (setq globalMin minPt globalMax maxPt) 
          (progn 
            (setq globalMin (MapMinMax globalMin minPt 'min)) 
            (setq globalMax (MapMinMax globalMax maxPt 'max)) 
          ) 
        ) 
      ) 
    ) 
    (setq i (1+ i)) 
  ) 
  (if globalMin 
    (list 
      (vlax-safearray->list globalMin) 
      (vlax-safearray->list globalMax) 
    ) 
  ) 
) 
 
;; ========== 向量 min/max ========== 
(defun MapMinMax (v1 v2 op / x1 y1 z1 x2 y2 z2) 
  (setq x1 (vlax-safearray-get-element v1 0) 
        y1 (vlax-safearray-get-element v1 1) 
        z1 (vlax-safearray-get-element v1 2) 
        x2 (vlax-safearray-get-element v2 0) 
        y2 (vlax-safearray-get-element v2 1) 
        z2 (vlax-safearray-get-element v2 2) 
  ) 
  (vlax-safearray-fill 
    (vlax-make-safearray vlax-vbDouble '(0 . 2)) 
    (list 
      ((if (= op 'min) min max) x1 x2) 
      ((if (= op 'min) min max) y1 y2) 
      ((if (= op 'min) min max) z1 z2) 
    ) 
  ) 
) 
 
;; ========== 复制并移动实体 ========== 
(defun CopyAndMoveEntities (ss tgtLayoutName offset / oldCTAB i ent obj newEnt doc) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (setq oldCTAB (getvar "CTAB")) 
  (setvar "CTAB" tgtLayoutName) 
 
  (setq i 0) 
  (repeat (sslength ss) 
    (setq ent (ssname ss i)) 
    (setq obj (vlax-ename->vla-object ent)) 
    ;; 跳过主视口：保留第一个视口（由 ClearLayout 保证存在） 
    (if (/= (vla-get-ObjectName obj) "AcDbViewport") 
      (progn 
        (setq newEnt (vla-Copy obj)) 
        (vla-Move newEnt (vlax-3d-point '(0 0 0)) (vlax-3d-point offset)) 
      ) 
      ;; 视口也复制（但 ClearLayout 已清空，所以这里不会重复） 
      (progn 
        (setq newEnt (vla-Copy obj)) 
        (vla-Move newEnt (vlax-3d-point '(0 0 0)) (vlax-3d-point offset)) 
      ) 
    ) 
    (setq i (1+ i)) 
  ) 
 
  (setvar "CTAB" oldCTAB) 
) 
 
;; ========== 清空布局（保留第一个视口）========== 
(defun ClearLayout (layName / oldCTAB doc layoutObj firstVP ss i ent obj) 
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
  (setq oldCTAB (getvar "CTAB")) 
  (setvar "CTAB" layName) 
  (setq layoutObj (vla-Item (vla-get-Layouts doc) layName)) 
 
  ;; 找到第一个视口（用于保留） 
  (setq firstVP nil) 
  (vlax-for obj (vla-get-Block layoutObj) 
    (if (and (= (vla-get-ObjectName obj) "AcDbViewport") (null firstVP)) 
      (setq firstVP obj) 
    ) 
  ) 
 
  ;; 删除所有实体，除了第一个视口 
  (setq ss (ssget "_X" (list (cons 410 layName)))) 
  (if ss 
    (progn 
      (setq i 0) 
      (repeat (sslength ss) 
        (setq ent (ssname ss i)) 
        (setq obj (vlax-ename->vla-object ent)) 
        (if (or (/= (vla-get-ObjectName obj) "AcDbViewport") 
                (/= obj firstVP)) 
          (vla-delete obj) 
        ) 
        (setq i (1+ i)) 
      ) 
    ) 
  ) 
 
  (setvar "CTAB" oldCTAB) 
) 
 
;; ========== 字符串工具 ========== 
(defun vl-string-trim (chars str / len) 
  (while (and (> (strlen str) 0) (vl-position (ascii (substr str 1 1)) (vl-string->list chars))) 
    (setq str (substr str 2)) 
  ) 
  (while (and (> (strlen str) 0) (vl-position (ascii (substr str (strlen str) 1)) (vl-string->list chars))) 
    (setq str (substr str 1 (1- (strlen str)))) 
  ) 
  str 
) 
 
(defun vl-string->list (str / i lst) 
  (setq i 0 lst '()) 
  (while (
    (setq lst (cons (ascii (substr str (setq i (1+ i)) 1)) lst)) 
  ) 
  (reverse lst) 
) 
 
(princ "\n命令 MERGELAYOUTS 已加载。") 
(princ "\n&#9989; 支持：块图框 + 多视口 + 自动创建默认视口") 
(princ "\n&#9989; 兼容 AutoCAD 2012 – 2024 标准版") 
(princ "\n&#128204; 使用方法：输入 MERGELAYOUTS，按编号选择布局。") 
(princ)

lengxiaxi · 发表于昨天 18:09

qifeifei 发表于 2025-11-1 13:48
DCL和LSP源码文件在此，程序非常好用，但有几个小问题：
1、程序在每打开的一幅图中只能用一次，再次用就 ...

刘明，明天再来下载

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

[源码] 批量合并图纸又快又避免同名块影响,AI编写的