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

ynhh · 发表于 2025-10-31 20:48:43

批量合并图纸又快又避免同名块影响

AI编写的，一遍成活
经多次测试从5个图到100个图，均很快，且能自动避免同名块的影响

ynhh · 发表于 2025-10-31 23:06:43

qifeifei 发表于 2025-10-31 22:31
写lisp这种非热门代码、体验最好的是qwen

谢谢你的介绍
经测试，相同的提问，从头到尾
四五次修改都没有一次可用的
感觉还是差距大哈

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)

;;; 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)

ynhh · 发表于 2025-10-31 20:53:57

这是源码和测试文件，及合并后的图

;;;------------------------------------------------------------------
;;; 程序名称: MergeDWGs.lsp
;;; 功能: 批量合并指定文件夹下的所有DWG文件到当前图形
;;; - 通过对话框选择文件夹和设置间距
;;; - 自动处理块名冲突
;;; - 自定义排列布局
;;; 作者: AI Assistant
;;; 日期: 2025-10-31
;;;------------------------------------------------------------------
;;; 主函数，在AutoCAD中输入 MERGEDWGS 来运行
(defun C:MERGEDWGS (/ dcl_id folder_path x_space y_space col_count dwg_files
ins_pt current_col max_row_height current_y old_cmdecho old_filedia)
;; --- 1. 加载和显示DCL对话框 ---
(setq dcl_path (findfile "MergeDWGs.dcl"))
(if (not dcl_path)
(progn
(alert "错误：未找到 MergeDWGs.dcl 文件！\n请确保它与LSP文件在同一目录或AutoCAD支持路径下。")
(exit)
)
)
(setq dcl_id (load_dialog dcl_path))
(if (not (new_dialog "MergeDWGsDialog" dcl_id))
(exit)
)
;; --- 2. DCL对话框事件处理 ---
;; 浏览文件夹按钮的动作
(action_tile "browse"
"(setq folder_path (get_folder))
(if folder_path
(set_tile "folder_path" folder_path)
)"
)
;; 确定按钮的动作
(action_tile "accept"
"(progn
(setq folder_path (get_tile "folder_path"))
(setq x_space (distof (get_tile "x_space")))
(setq y_space (distof (get_tile "y_space")))
(setq col_count (atoi (get_tile "col_count")))
(if (or (not folder_path) (= folder_path ""))
(alert "请选择一个文件夹！")
(if (or (not x_space) (not y_space) (<= col_count 0))
(alert "无效的间隔或每行数量设置！")
(done_dialog 1) ; 值为1表示成功
)
)
)"
)
;; --- 3. 启动对话框并获取用户输入 ---
(if (= (start_dialog) 1)
(progn
;; --- 4. 准备工作 ---
(setq old_cmdecho (getvar "CMDECHO"))
(setq old_filedia (getvar "FILEDIA"))
(setvar "CMDECHO" 0)
(setvar "FILEDIA" 0)
(princ "\n正在准备合并图纸...")
;; 检查文件夹路径最后是否有斜杠
(if (/= (substr folder_path (strlen folder_path)) "\")
(setq folder_path (strcat folder_path "\"))
)
;; 获取文件夹内所有DWG文件
(setq dwg_files (vl-directory-files folder_path "*.dwg" 1))
(if (not dwg_files)
(alert (strcat "在文件夹 " folder_path " 中未找到任何DWG文件！"))
(progn
;; --- 5. 开始循环合并 ---
(setq ins_pt (list 0.0 0.0 0.0)) ; 初始插入点
(setq current_col 0) ; 当前列数
(setq current_y 0.0) ; 当前行的Y坐标
(setq max_row_height 0.0) ; 当前行的最大高度
(foreach dwg_name dwg_files
(setq full_path (strcat folder_path dwg_name))
(setq xref_name (vl-filename-base dwg_name)) ; 使用文件名作为外部参照名
(princ (strcat "\n正在处理: " dwg_name))
;; 使用XREF-BIND方法来避免块名冲突
;; 1. 附加外部参照 (Attach Xref)
(command "_.XREF" "_A" full_path "0,0,0" "" "" "")
;; 2. 绑定外部参照 (Bind Xref) - 'Bind'类型会自动重命名冲突对象
(command "_.XREF" "_B" xref_name)
;; 3. 绑定后会生成一个块参照，获取它的信息
(setq last_ent (entlast))
(if last_ent
(progn
(setq obj (vlax-ename->vla-object last_ent))
(vla-getboundingbox obj 'min_pt 'max_pt)
(setq min_pt (vlax-safearray->list min_pt))
(setq max_pt (vlax-safearray->list max_pt))
;; 计算包围盒的宽度和高度
(setq width (- (car max_pt) (car min_pt)))
(setq height (- (cadr max_pt) (cadr min_pt)))
;; 4. 移动块参照到计算好的位置
(command "_.MOVE" last_ent "" "0,0,0" ins_pt)
;; 5. （可选）分解块参照，使其变为普通实体
(command "_.EXPLODE" last_ent)
;; 6. 更新下一个插入点的位置
;; 更新当前行的最大高度
(if (> height max_row_height)
(setq max_row_height height)
)
;; 增加列计数器
(setq current_col (1+ current_col))
;; 检查是否需要换行
(if (>= current_col col_count)
(progn
;; 换行
(setq current_col 0) ; 重置列计数
(setq current_y (- current_y max_row_height y_space)) ; 计算新行的Y坐标
(setq max_row_height 0.0) ; 重置行高
(setq ins_pt (list 0.0 current_y 0.0)) ; 设置新行的第一个插入点
)
(progn
;; 不换行，更新同一行中的下一个插入点
(setq ins_pt (list (+ (car ins_pt) width x_space) (cadr ins_pt) 0.0))
)
)
)
(princ (strcat " ... 无法处理 " dwg_name))
)
)
(princ "\n所有图纸合并完成！")
)
)
;; --- 6. 恢复系统变量 ---
(setvar "CMDECHO" old_cmdecho)
(setvar "FILEDIA" old_filedia)
(princ)
)
(princ "\n*已取消*")
)
(princ)
)
;;; 辅助函数: 弹出Windows文件夹选择对话框
(defun get_folder (/ shell folder folder_path)
(vl-load-com)
(if (setq shell (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application"))
(progn
(setq folder (vlax-invoke-method shell 'BrowseForFolder 0 "请选择包含DWG图纸的文件夹" 0))
(vlax-release-object shell)
(if folder
(progn
(setq folder_path (vlax-get-property folder 'Self))
(setq folder_path (vlax-get-property folder_path 'Path))
(vlax-release-object folder)
)
)
)
)
folder_path
)
(princ "\nMergeDWGs.lsp 已加载。输入 MERGEDWGS 启动程序。")
(princ)

;;;------------------------------------------------------------------ 
;;; 程序名称: MergeDWGs.lsp 
;;; 功能: 批量合并指定文件夹下的所有DWG文件到当前图形 
;;;       - 通过对话框选择文件夹和设置间距 
;;;       - 自动处理块名冲突 
;;;       - 自定义排列布局 
;;; 作者: AI Assistant 
;;; 日期: 2025-10-31 
;;;------------------------------------------------------------------ 
 
;;; 主函数，在AutoCAD中输入 MERGEDWGS 来运行 
(defun C:MERGEDWGS (/ dcl_id folder_path x_space y_space col_count dwg_files 
                      ins_pt current_col max_row_height current_y old_cmdecho old_filedia) 
 
  ;; --- 1. 加载和显示DCL对话框 --- 
  (setq dcl_path (findfile "MergeDWGs.dcl")) 
  (if (not dcl_path) 
    (progn 
      (alert "错误：未找到 MergeDWGs.dcl 文件！\n请确保它与LSP文件在同一目录或AutoCAD支持路径下。") 
      (exit) 
    ) 
  ) 
   
  (setq dcl_id (load_dialog dcl_path)) 
  (if (not (new_dialog "MergeDWGsDialog" dcl_id)) 
    (exit) 
  ) 
 
  ;; --- 2. DCL对话框事件处理 --- 
  ;; 浏览文件夹按钮的动作 
  (action_tile "browse" 
    "(setq folder_path (get_folder)) 
     (if folder_path 
       (set_tile "folder_path" folder_path) 
     )" 
  ) 
 
  ;; 确定按钮的动作 
  (action_tile "accept" 
    "(progn 
       (setq folder_path (get_tile "folder_path")) 
       (setq x_space (distof (get_tile "x_space"))) 
       (setq y_space (distof (get_tile "y_space"))) 
       (setq col_count (atoi (get_tile "col_count"))) 
       (if (or (not folder_path) (= folder_path "")) 
         (alert "请选择一个文件夹！") 
         (if (or (not x_space) (not y_space) (<= col_count 0)) 
           (alert "无效的间隔或每行数量设置！") 
           (done_dialog 1) ; 值为1表示成功 
         ) 
       ) 
     )" 
  ) 
   
  ;; --- 3. 启动对话框并获取用户输入 --- 
  (if (= (start_dialog) 1) 
    (progn 
      ;; --- 4. 准备工作 --- 
      (setq old_cmdecho (getvar "CMDECHO")) 
      (setq old_filedia (getvar "FILEDIA")) 
      (setvar "CMDECHO" 0) 
      (setvar "FILEDIA" 0) 
      (princ "\n正在准备合并图纸...") 
 
      ;; 检查文件夹路径最后是否有斜杠 
      (if (/= (substr folder_path (strlen folder_path)) "\") 
        (setq folder_path (strcat folder_path "\")) 
      ) 
 
      ;; 获取文件夹内所有DWG文件 
      (setq dwg_files (vl-directory-files folder_path "*.dwg" 1)) 
 
      (if (not dwg_files) 
        (alert (strcat "在文件夹 " folder_path " 中未找到任何DWG文件！")) 
        (progn 
          ;; --- 5. 开始循环合并 --- 
          (setq ins_pt (list 0.0 0.0 0.0)) ; 初始插入点 
          (setq current_col 0)             ; 当前列数 
          (setq current_y 0.0)             ; 当前行的Y坐标 
          (setq max_row_height 0.0)        ; 当前行的最大高度 
 
          (foreach dwg_name dwg_files 
            (setq full_path (strcat folder_path dwg_name)) 
            (setq xref_name (vl-filename-base dwg_name)) ; 使用文件名作为外部参照名 
             
            (princ (strcat "\n正在处理: " dwg_name)) 
 
            ;; 使用XREF-BIND方法来避免块名冲突 
            ;; 1. 附加外部参照 (Attach Xref) 
            (command "_.XREF" "_A" full_path "0,0,0" "" "" "") 
             
            ;; 2. 绑定外部参照 (Bind Xref) - 'Bind'类型会自动重命名冲突对象 
            (command "_.XREF" "_B" xref_name) 
             
            ;; 3. 绑定后会生成一个块参照，获取它的信息 
            (setq last_ent (entlast)) 
            (if last_ent 
              (progn 
                (setq obj (vlax-ename->vla-object last_ent)) 
                (vla-getboundingbox obj 'min_pt 'max_pt) 
                (setq min_pt (vlax-safearray->list min_pt)) 
                (setq max_pt (vlax-safearray->list max_pt)) 
                
                ;; 计算包围盒的宽度和高度 
                (setq width (- (car max_pt) (car min_pt))) 
                (setq height (- (cadr max_pt) (cadr min_pt))) 
 
                ;; 4. 移动块参照到计算好的位置 
                (command "_.MOVE" last_ent "" "0,0,0" ins_pt) 
 
                ;; 5. （可选）分解块参照，使其变为普通实体 
                (command "_.EXPLODE" last_ent) 
 
                ;; 6. 更新下一个插入点的位置 
                ;; 更新当前行的最大高度 
                (if (> height max_row_height) 
                  (setq max_row_height height) 
                ) 
                
                ;; 增加列计数器 
                (setq current_col (1+ current_col)) 
                
                ;; 检查是否需要换行 
                (if (>= current_col col_count) 
                  (progn 
                    ;; 换行 
                    (setq current_col 0) ; 重置列计数 
                    (setq current_y (- current_y max_row_height y_space)) ; 计算新行的Y坐标 
                    (setq max_row_height 0.0) ; 重置行高 
                    (setq ins_pt (list 0.0 current_y 0.0)) ; 设置新行的第一个插入点 
                  ) 
                  (progn 
                    ;; 不换行，更新同一行中的下一个插入点 
                    (setq ins_pt (list (+ (car ins_pt) width x_space) (cadr ins_pt) 0.0)) 
                  ) 
                ) 
              ) 
              (princ (strcat " ... 无法处理 " dwg_name)) 
            ) 
          ) 
          (princ "\n所有图纸合并完成！") 
        ) 
      ) 
       
      ;; --- 6. 恢复系统变量 --- 
      (setvar "CMDECHO" old_cmdecho) 
      (setvar "FILEDIA" old_filedia) 
      (princ) 
    ) 
    (princ "\n*已取消*") 
  ) 
  (princ) 
) 
 
;;; 辅助函数: 弹出Windows文件夹选择对话框 
(defun get_folder (/ shell folder folder_path) 
  (vl-load-com) 
  (if (setq shell (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application")) 
    (progn 
      (setq folder (vlax-invoke-method shell 'BrowseForFolder 0 "请选择包含DWG图纸的文件夹" 0)) 
      (vlax-release-object shell) 
      (if folder 
        (progn 
          (setq folder_path (vlax-get-property folder 'Self)) 
          (setq folder_path (vlax-get-property folder_path 'Path)) 
          (vlax-release-object folder) 
        ) 
      ) 
    ) 
  ) 
  folder_path 
) 
 
(princ "\nMergeDWGs.lsp 已加载。输入 MERGEDWGS 启动程序。") 
(princ)

// DCL file for DWG Merge Utility
// Save as MergeDWGs.dcl
MergeDWGsDialog : dialog {
label = "批量合并DWG图纸";
: column {
: boxed_row {
label = "源文件夹";
: edit_box { key = "folder_path"; width = 45; }
: button { key = "browse"; label = "浏览..."; fixed_width = true; }
}
: boxed_column {
label = "布局设置";
: row {
: edit_box { key = "x_space"; label = "横向间隔 (X):"; value = "1000"; edit_width = 8; }
: edit_box { key = "y_space"; label = "纵向间隔 (Y):"; value = "1000"; edit_width = 8; }
}
: edit_box { key = "col_count"; label = "每行图纸数量:"; value = "5"; edit_width = 8; }
}
}
ok_cancel;
}

xiaotao · 发表于 2025-10-31 20:52:57

用哪个AI写的？

lhg · 发表于 2025-10-31 20:55:31

不错！！！不错！！！不错！！！

ynhh · 发表于 2025-10-31 21:01:41

DCL和LSP源码文件在此，程序非常好用，但有几个小问题：
1、程序在每打开的一幅图中只能用一次，再次用就出错，经反馈修改几次一直没能改正，后因没充费也就没法再修改了，这程序不是我用的只是爱好试试AI，半年收费80元哈。
2、程序用过后，保存图时被改为不能调用对话框选择路径，感觉是改了那个系统变量。
3、程序结束后要有个运行时间就好了。

以下是AI给出的解决方案，但没试成功

解决方案：
总是卸载对话框：在 (start_dialog) 执行完毕后，无论用户是点击了确定还是取消，都必须立即调用 (unload_dialog dcl_id) 来释放对话框资源。在我的代码中，这一行 (unload_dialog dcl_id) 放在 (start_dialog) 的正下方，确保它一定会被执行。
使用局部变量：在函数定义时使用 (defun c:MDWG (/ var1 var2 ...)) 的方式声明所有变量为局部变量。这样可以防止变量（尤其是 dcl_id）污染全局环境，避免不同次运行之间互相干扰。
完善的错误处理：通过定义局部的 *error* 函数，可以确保即使用户按 ESC 键或程序在执行过程中发生其他错误，(unload_dialog dcl_id) 也能被调用，从而保证程序的健壮性。

以下是AI给出的程序使用说明：

如何使用
保存文件：将上述两段代码分别保存为 MergeDWGs.dcl 和 MergeDWGs.lsp，并确保它们在同一个文件夹里。
加载程序：
打开AutoCAD。
在命令行输入 APPLOAD 命令。
在弹出的对话框中，找到并选择 MergeDWGs.lsp 文件，然后点击“加载”。
或者，您可以直接将 MergeDWGs.lsp 文件拖拽到AutoCAD的绘图窗口中。
运行程序：
在命令行输入 MERGEDWGS 并按回车。
操作对话框：
程序会弹出一个名为“批量合并DWG图纸”的对话框。
点击 “浏览...” 按钮，选择您存放DWG图纸的文件夹。
在 “横向间隔 (X)” 和 “纵向间隔 (Y)” 输入框中设置图与图之间的距离。
在 “每行图纸数量” 中设置一行排列几个图。
点击 “确定”。
等待完成：
程序将开始自动处理，您可以在命令行看到处理进度。
处理完成后，所有图纸将按照您设置的布局排列在当前图形空间中，并且内部的块名都已自动重命名，不会发生冲突。
注意事项
程序会将所有图纸合并到当前打开的这个DWG文件中。建议在一个新建的空白文件中运行此程序。
图纸数量越多，处理时间越长，请耐心等待。
程序最后会分解（Explode）插入的图块，使它们成为独立的实体。如果您希望保留它们为独立的块（块名为原文件名），可以注释掉 (command "_.EXPLODE" last_ent) 这一行代码。
默认的间隔单位与您当前图形的单位一致。如果您的图纸单位是毫米，那么1000就代表1000毫米。
内容由AI生成、真假自行辨别！

ynhh · 发表于 2025-10-31 21:03:13

xiaotao 发表于 2025-10-31 20:52
用哪个AI写的？

claude
这是个收费的AI，当然比国产免费的应好的多吧

ynhh · 发表于 2025-10-31 21:10:01

就是用的这个AI

如有老师能再将程序完善一下就好了
谢谢

w379106181 · 发表于 2025-10-31 21:25:30

感谢大神分享

qifeifei · 发表于 2025-10-31 22:31:58

ynhh 发表于 2025-10-31 21:03
claude
这是个收费的AI，当然比国产免费的应好的多吧

写lisp这种非热门代码、体验最好的是qwen

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

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

本帖子中包含更多资源

评分

点评

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源