f4800
发表于 2025-11-2 17:22:51
在CAD图纸里有多个布局和一个模型空间，每个布局的图框和位置基本上是一致的。
目标：
1、把多个布局合并到一个布局里
2、可选需要合并的布局数量和合并后的布局
3、是否删除旧的布局，建议默认删除
4、保持合并后的布局排版，建议横向排列，图框间距 50~100mm
是否可以用lisp语言实现这些功能
用国内免费的ai 测试了几个 运行中均出现错误
f4800
发表于 2025-11-2 18:08:29
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)
lengxiaxi
发表于 2025-11-2 18:09:07
qifeifei 发表于 2025-11-1 13:48
DCL和LSP源码文件在此，程序非常好用，但有几个小问题：
1、程序在每打开的一幅图中只能用一次，再次用就 ...
刘明，明天再来下载
qwsss31
发表于 2025-11-3 13:05:47
能用哎可以
429014673
发表于 2025-11-3 14:38:09
ynhh 发表于 2025-11-2 12:57
claude
这是个收费的AI，当然比国产免费的应好的多吧
哪个网？一些网上报价都好贵
ynhh
发表于 2025-11-3 16:57:25
429014673 发表于 2025-11-3 14:38
哪个网？一些网上报价都好贵
claude
这是个收费的AI，半年80元，应比国产免费的好吧
gwar
发表于 2025-11-4 08:41:25
感谢分享
konoko
发表于 2025-11-4 16:09:45
本帖最后由 konoko 于 2025-11-4 16:11 编辑
f4800 发表于 2025-11-2 18:08
ai的代码 还有不少问题 排版还是有问题
感谢分享，但是跟楼主提供的代码不是一个方向。一个是多文档合并成一个文档，这在实际工作中还挺多的，合并后可以方便绘图和打印。你这个是Layout合并。
水洗可口可乐
发表于 2025-11-7 11:30:07
qifeifei 发表于 2025-11-1 13:48
DCL和LSP源码文件在此，程序非常好用，但有几个小问题：
1、程序在每打开的一幅图中只能用一次，再次用就 ...
提示找不到这个DCL
伊偭
发表于 2025-11-7 11:37:39
感谢楼主分享！