批量改变的矩形上下方向的高度（竖向长度），用一条水平线作为目标，将多个矩形的一侧（上边或下边）拉伸到那条线上，同时保持矩形的宽度和另一侧边位置不变。

一个一键批量拉伸矩形高度的 LISP 程序，支持选择水平参考线，并将矩形上边（或下边）对齐到该线。

✅ 以线为界，批量调整矩形高度（竖向拉伸）

程序功能

  • 选择一条水平直线（程序自动获取其 Y 坐标）。
  • 选择多个矩形（轴对齐矩形，边平行于坐标轴）。
  • 选择拉伸模式：
    • 上边对齐到线（底部固定，顶部拉伸到参考线）
    • 下边对齐到线（顶部固定，底部拉伸到参考线）
  • 矩形宽度和另一侧位置完全不变。

代码（直接粘贴到 CAD 命令行）

(defun C:StretchHeightToLine ( / lineEnt lineY ss i ent pts minX maxX minY maxY newMinY newMaxY mode newPts newEnt)
  (setq lineEnt (car (entsel "\n选择水平参考线（直线）：")))
  (if (not lineEnt) (progn (prompt "\n未选择直线") (exit)))
  (setq lineY (cadr (vlax-curve-getStartPoint lineEnt)))  ; 取直线的 Y 坐标

  (setq ss (ssget '((0 . "LWPOLYLINE") (70 . 1)))) ; 只选闭合多段线
  (if (not ss) (progn (prompt "\n未选择任何矩形") (exit)))

  (initget "Top Bottom")
  (setq mode (getkword "\n对齐方式 [上边对齐到线(Top)/下边对齐到线(Bottom)]: "))
  (if (not mode) (exit))

  (setq i 0)
  (repeat (sslength ss)
    (setq ent (ssname ss i))
    (setq pts (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget ent))))
    (if (>= (length pts) 4)
      (progn
        (setq minX (apply 'min (mapcar 'car pts)))
        (setq maxX (apply 'max (mapcar 'car pts)))
        (setq minY (apply 'min (mapcar 'cadr pts)))
        (setq maxY (apply 'max (mapcar 'cadr pts)))

        (cond
          ((= mode "Top")
           ;; 顶部对齐到线：底边不变，顶边改为 lineY
           (setq newMinY minY)
           (setq newMaxY lineY)
          )
          ((= mode "Bottom")
           ;; 底部对齐到线：顶边不变，底边改为 lineY
           (setq newMinY lineY)
           (setq newMaxY maxY)
          )
        )

        ;; 构建新顶点（左下 -> 右下 -> 右上 -> 左上）
        (setq newPts (list
                      (list minX newMinY)
                      (list maxX newMinY)
                      (list maxX newMaxY)
                      (list minX newMaxY)
                     ))

        ;; 更新多段线
        (setq newEnt (entget ent))
        (setq newEnt (vl-remove-if '(lambda (x) (= (car x) 10)) newEnt))
        (foreach p newPts
          (setq newEnt (append newEnt (list (cons 10 p))))
        )
        (entmod newEnt)
      )
    )
    (setq i (1+ i))
  )
  (prompt (strcat "\n已修改 " (itoa i) " 个矩形，参考线 Y = " (rtos lineY 2 2)))
  (princ)
)

操作步骤

  1. 加载代码：在 CAD 命令行粘贴全部代码，按回车。
    • 如果提示“函数已加载”，则可直接使用。
    • 如果粘贴不成功（比如多行提示），请先输入 VLIDE 打开编辑器，新建文件粘贴，保存为 .lsp 文件，再用 APPLOAD 加载。
  2. 执行命令：输入 StretchHeightToLine 回车。
  3. 选择参考线：单击一条水平直线（多段线的直线段也可，程序会自动取它的 Y 坐标）。
  4. 选择矩形：框选所有要修改的矩形，按回车。
  5. 选择对齐方式：
    • 输入 T 选择「上边对齐到线」 → 矩形底部固定，顶部拉伸到参考线。
    • 输入 B 选择「下边对齐到线」 → 矩形顶部固定，底部拉伸到参考线。
  6. 程序自动完成所有矩形的竖向拉伸。

🔁 相反方向：固定顶边，底部拉伸？固定底边，顶部拉伸？

程序已经通过模式选择实现了两种需求：

  • Top 模式：底部固定，顶部移动（改变高度）
  • Bottom 模式：顶部固定，底部移动（改变高度）

完全满足“一条线作为目标，矩形上下长度拉伸过去”。

📐 特殊情况：如果参考线位于矩形中间（压缩或拉伸）

程序不判断参考线相对于矩形的位置。如果参考线 Y 坐标位于矩形原有高度范围之内：

  • Top 模式：新高度变小（顶部下移）→ 压缩矩形。
  • Bottom 模式：新高度变小（底部上移）→ 压缩矩形。 如果需要反向拉伸（比如从中间往外拉），请手动移动参考线或使用其他命令。