动态加矩形

林小林子 · 发表于 2025-12-4 10:50:21

本帖最后由林小林子于 2025-12-7 10:37 编辑

oysheji 发表于 2025-11-17 17:35
为什么偏移的距离带小数点呢

;;动态框绘制 By 明经通道 Gu_xl 修改版 - 增强版
(defun c:DD (/ GetScreenCoords gr lmts loop pt s1 s2 s3 s4 p1 p2 p3 p4 ll ru lu rl
dist thickness move_dist direction ent_old input new_thick)
;;定义全局变量存储板厚和移动距离
(if (not *thickness*)
(setq *thickness* 18.0) ;;默认板厚为18
)
(if (not *move-distance*)
(setq *move-distance* 0.0) ;;默认移动距离为0
)
;;设置默认值
(setq thickness *thickness*)
(setq move_dist *move-distance*)
;;取得当前绘图区屏幕的左下角和右上角的坐标
(defun GetScreenCoords (/ c03 c08 c04 c05 c07 c06 c09 c01 c02)
(setq c03 (getvar "viewctr")
c03 (trans c03 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c07 (car c04)
c06 (cadr c04)
c09 (/ (* c08 c07) c06)
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
(princ (strcat "\n当前设置: 板厚=" (rtos thickness 2 2) " 距离=" (rtos move_dist 2 2) " (按S修改设置)"))
(setq loop t)
(while loop
(setq lmts (GetScreenCoords))
(setq gr (grread t 15 0))
(cond
((= 5 (car gr)) ;;鼠标移动
(setq pt (cadr gr))
(if (and
(setq s1 (ssget "F"
(list pt (list (car pt) (cadadr lmts) 0))
'((0 . "*line,arc,circle"))
)
) ;_ 向上
(setq s2 (ssget "F"
(list pt (list (car pt) (cadar lmts) 0))
'((0 . "*line,arc,circle"))
)
) ;_ 向下
(setq s3 (ssget "F"
(list pt (list (caar lmts) (cadr pt) 0))
'((0 . "*line,arc,circle"))
)
) ;_ 向左
(setq s4 (ssget "F"
(list pt (list (caadr lmts) (cadr pt) 0))
'((0 . "*line,arc,circle"))
)
) ;_ 向右
)
(progn
(setq p1 (trans (cadar (cdddar (ssnamex s1))) 0 1)) ;_ 上点
(setq p2 (trans (cadar (cdddar (ssnamex s2))) 0 1)) ;_ 下点
(setq p3 (trans (cadar (cdddar (ssnamex s3))) 0 1)) ;_ 左点
(setq p4 (trans (cadar (cdddar (ssnamex s4))) 0 1)) ;_ 右点
(setq ll (apply 'mapcar (cons 'min (list p1 p2 p3 p4)))) ;_ 左下角点
(setq ru (apply 'mapcar (cons 'max (list p1 p2 p3 p4)))) ;_ 右上角点
(setq lu (list (car ll) (cadr ru) 0)) ;_ 左上角点
(setq rl (list (car ru) (cadr ll) 0)) ;_ 右下角点
;;判断鼠标在矩形内部的位置
(setq direction (GetMouseDirection pt ll ru))
(redraw)
;;绘制原始矩形
(grdraw ll lu 1)
(grdraw lu ru 1)
(grdraw ru rl 1)
(grdraw rl ll 1)
;;根据鼠标位置绘制偏移矩形
(DrawOffsetRect ll ru direction thickness move_dist)
)
(redraw)
)
)
((= 3 (car gr)) ;;鼠标左键点击
(setq loop nil)
(if (and ll ru direction)
(progn
;;创建偏移矩形
(CreateOffsetRect ll ru direction thickness move_dist)
)
(command "_.rectang")
)
)
((= 2 (car gr)) ;;键盘输入
(cond
((= (cadr gr) 27) ;;ESC键退出
(setq loop nil)
)
((or (= (cadr gr) 83) (= (cadr gr) 115)) ;;S键 - 修改设置
;;获取板厚输入
(initget 6) ; 禁止负数和0
(setq new_thick (getreal (strcat "\n请输入板厚 <" (rtos *thickness* 2 2) ">: ")))
(if new_thick
(setq *thickness* new_thick thickness new_thick)
)
;;获取移动距离输入 - 修改为允许0在内的正数值
(initget 4) ; 允许0和正数，禁止负数
(setq move_dist (getreal (strcat "\n请输入移动距离 <" (rtos *move-distance* 2 2) ">: ")))
(if move_dist
(setq *move-distance* move_dist)
(setq move_dist *move-distance*)
)
(princ (strcat "\n当前设置: 板厚=" (rtos thickness 2 2) " 距离=" (rtos move_dist 2 2) " (按S修改设置)"))
)
)
)
)
)
(redraw)
(princ)
)
;;判断鼠标在矩形内部的位置
(defun GetMouseDirection (pt ll ru / center relX relY)
(setq center (list (/ (+ (car ll) (car ru)) 2.0)
(/ (+ (cadr ll) (cadr ru)) 2.0)
(caddr ll)))
;;计算相对位置
(setq relX (- (car pt) (car center))
relY (- (cadr pt) (cadr center)))
;;根据相对位置判断方向
(cond
((and (> (abs relY) (abs relX)) (> relY 0)) "top") ;;上部
((and (> (abs relY) (abs relX)) (< relY 0)) "bottom") ;;下部
((and (> (abs relX) (abs relY)) (> relX 0)) "right") ;;右侧
((and (> (abs relX) (abs relY)) (< relX 0)) "left") ;;左侧
(t "top") ;;默认上部
)
)
;;绘制偏移矩形
(defun DrawOffsetRect (ll ru direction thickness move_dist / newLL newRU newLU newRL)
(cond
((= direction "top") ;;上部矩形 - 向下移动
(setq newLL (list (car ll) (- (- (cadr ru) thickness) move_dist) 0)
newRU (list (car ru) (- (cadr ru) move_dist) 0))
)
((= direction "bottom") ;;下部矩形 - 向上移动
(setq newLL (list (car ll) (+ (cadr ll) move_dist) 0)
newRU (list (car ru) (+ (+ (cadr ll) thickness) move_dist) 0))
)
((= direction "left") ;;左侧矩形 - 向右移动
(setq newLL (list (+ (car ll) move_dist) (cadr ll) 0)
newRU (list (+ (+ (car ll) thickness) move_dist) (cadr ru) 0))
)
((= direction "right") ;;右侧矩形 - 向左移动
(setq newLL (list (- (- (car ru) thickness) move_dist) (cadr ll) 0)
newRU (list (- (car ru) move_dist) (cadr ru) 0))
)
)
(setq newLU (list (car newLL) (cadr newRU) 0)
newRL (list (car newRU) (cadr newLL) 0))
;;绘制偏移矩形（用不同颜色显示，比如绿色）
(grdraw newLL newLU 3)
(grdraw newLU newRU 3)
(grdraw newRU newRL 3)
(grdraw newRL newLL 3)
)
;;创建偏移矩形
(defun CreateOffsetRect (ll ru direction thickness move_dist / newLL newRU)
(cond
((= direction "top") ;;上部矩形 - 向下移动
(setq newLL (list (car ll) (- (- (cadr ru) thickness) move_dist) 0)
newRU (list (car ru) (- (cadr ru) move_dist) 0))
)
((= direction "bottom") ;;下部矩形 - 向上移动
(setq newLL (list (car ll) (+ (cadr ll) move_dist) 0)
newRU (list (car ru) (+ (+ (cadr ll) thickness) move_dist) 0))
)
((= direction "left") ;;左侧矩形 - 向右移动
(setq newLL (list (+ (car ll) move_dist) (cadr ll) 0)
newRU (list (+ (+ (car ll) thickness) move_dist) (cadr ru) 0))
)
((= direction "right") ;;右侧矩形 - 向左移动
(setq newLL (list (- (- (car ru) thickness) move_dist) (cadr ll) 0)
newRU (list (- (car ru) move_dist) (cadr ru) 0))
)
)
(command "_.rectang" "_non" newLL "_non" newRU)
)
;;删除识别内空的矩形
(defun c:DeleteInnerRects (/ ss i ent obj minpt maxpt bounds allrects outer inner todelete)
(princ "\n选择要清理的矩形集合: ")
(setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4)))) ; 选择多段线矩形
(if ss
(progn
(setq allrects '())
;;收集所有矩形及其边界
(setq i 0)
(while (< i (sslength ss))
(setq ent (ssname ss i))
(setq obj (vlax-ename->vla-object ent))
(vla-getboundingbox obj 'minpt 'maxpt)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt))
(setq allrects (cons (list ent minpt maxpt) allrects))
(setq i (1+ i))
)
;;找出内空的矩形（被其他矩形完全包含的矩形）
(setq todelete '())
(foreach rect1 allrects
(foreach rect2 allrects
(if (and (not (equal (car rect1) (car rect2))) ; 不是同一个矩形
(IsInside (cadr rect1) (caddr rect1) ; rect1完全在rect2内部
(cadr rect2) (caddr rect2)))
(setq todelete (cons (car rect1) todelete))
)
)
)
;;删除内空的矩形
(if todelete
(progn
(setq todelete (vl-remove-duplicates todelete)) ; 去除重复项
(foreach ent todelete
(entdel ent)
)
(princ (strcat "\n删除了 " (itoa (length todelete)) " 个内空矩形"))
)
(princ "\n未找到内空矩形")
)
)
(princ "\n未选择到矩形")
)
(princ)
)
;;判断矩形1是否完全在矩形2内部
(defun IsInside (min1 max1 min2 max2)
(and
(>= (car min1) (car min2))
(>= (cadr min1) (cadr min2))
(<= (car max1) (car max2))
(<= (cadr max1) (cadr max2))
)
)
(princ "\n动态框绘制程序加载完成，输入 DD 运行，输入 DeleteInnerRects 删除内空矩形")
(princ)

;;动态框绘制 By 明经通道 Gu_xl 修改版 - 增强版 
(defun c:DD (/ GetScreenCoords gr lmts loop pt s1 s2 s3 s4 p1 p2 p3 p4 ll ru lu rl 
               dist thickness move_dist direction ent_old input new_thick) 
  ;;定义全局变量存储板厚和移动距离 
  (if (not *thickness*) 
    (setq *thickness* 18.0)  ;;默认板厚为18 
  ) 
  (if (not *move-distance*) 
    (setq *move-distance* 0.0)  ;;默认移动距离为0 
  ) 
   
  ;;设置默认值 
  (setq thickness *thickness*) 
  (setq move_dist *move-distance*) 
   
  ;;取得当前绘图区屏幕的左下角和右上角的坐标 
  (defun GetScreenCoords (/ c03 c08 c04 c05 c07 c06 c09 c01 c02) 
    (setq c03 (getvar "viewctr") 
          c03 (trans c03 1 2) 
          c08 (getvar "viewsize") 
          c04 (getvar "screensize") 
          c07 (car c04) 
          c06 (cadr c04) 
          c09 (/ (* c08 c07) c06) 
          c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
          c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
          c01 (trans c01 2 1) 
          c02 (trans c02 2 1) 
    ) 
    (list c01 c02) 
  ) 
   
  (princ (strcat "\n当前设置: 板厚=" (rtos thickness 2 2) " 距离=" (rtos move_dist 2 2) " (按S修改设置)")) 
   
  (setq loop t) 
  (while loop 
    (setq lmts (GetScreenCoords)) 
    (setq gr (grread t 15 0)) 
    (cond 
      ((= 5 (car gr))  ;;鼠标移动 
        (setq pt (cadr gr)) 
        (if (and 
              (setq s1 (ssget "F" 
                              (list pt (list (car pt) (cadadr lmts) 0)) 
                              '((0 . "*line,arc,circle")) 
                       ) 
              ) ;_ 向上 
              (setq s2 (ssget "F" 
                              (list pt (list (car pt) (cadar lmts) 0)) 
                              '((0 . "*line,arc,circle")) 
                       ) 
              ) ;_ 向下 
              (setq s3 (ssget "F" 
                              (list pt (list (caar lmts) (cadr pt) 0)) 
                              '((0 . "*line,arc,circle")) 
                       ) 
              ) ;_ 向左 
              (setq s4 (ssget "F" 
                              (list pt (list (caadr lmts) (cadr pt) 0)) 
                              '((0 . "*line,arc,circle")) 
                       ) 
              ) ;_ 向右 
            ) 
          (progn 
            (setq p1 (trans (cadar (cdddar (ssnamex s1))) 0 1)) ;_ 上点 
            (setq p2 (trans (cadar (cdddar (ssnamex s2))) 0 1)) ;_ 下点 
            (setq p3 (trans (cadar (cdddar (ssnamex s3))) 0 1)) ;_ 左点 
            (setq p4 (trans (cadar (cdddar (ssnamex s4))) 0 1)) ;_ 右点 
            (setq ll (apply 'mapcar (cons 'min (list p1 p2 p3 p4)))) ;_ 左下角点 
            (setq ru (apply 'mapcar (cons 'max (list p1 p2 p3 p4)))) ;_ 右上角点 
            (setq lu (list (car ll) (cadr ru) 0)) ;_ 左上角点 
            (setq rl (list (car ru) (cadr ll) 0)) ;_ 右下角点 
             
            ;;判断鼠标在矩形内部的位置 
            (setq direction (GetMouseDirection pt ll ru)) 
             
            (redraw) 
            ;;绘制原始矩形 
            (grdraw ll lu 1) 
            (grdraw lu ru 1) 
            (grdraw ru rl 1) 
            (grdraw rl ll 1) 
             
            ;;根据鼠标位置绘制偏移矩形 
            (DrawOffsetRect ll ru direction thickness move_dist) 
          ) 
          (redraw) 
        ) 
      ) 
      ((= 3 (car gr))  ;;鼠标左键点击 
        (setq loop nil) 
        (if (and ll ru direction) 
          (progn 
            ;;创建偏移矩形 
            (CreateOffsetRect ll ru direction thickness move_dist) 
          ) 
          (command "_.rectang") 
        ) 
      ) 
      ((= 2 (car gr))  ;;键盘输入 
        (cond 
          ((= (cadr gr) 27)  ;;ESC键退出 
            (setq loop nil) 
          ) 
          ((or (= (cadr gr) 83) (= (cadr gr) 115))  ;;S键 - 修改设置 
            ;;获取板厚输入 
            (initget 6) ; 禁止负数和0 
            (setq new_thick (getreal (strcat "\n请输入板厚 <" (rtos *thickness* 2 2) ">: "))) 
            (if new_thick 
              (setq *thickness* new_thick thickness new_thick) 
            ) 
             
            ;;获取移动距离输入 - 修改为允许0在内的正数值 
            (initget 4) ; 允许0和正数，禁止负数 
            (setq move_dist (getreal (strcat "\n请输入移动距离 <" (rtos *move-distance* 2 2) ">: "))) 
            (if move_dist 
              (setq *move-distance* move_dist) 
              (setq move_dist *move-distance*) 
            ) 
             
            (princ (strcat "\n当前设置: 板厚=" (rtos thickness 2 2) " 距离=" (rtos move_dist 2 2) " (按S修改设置)")) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (redraw) 
  (princ) 
) 
 
;;判断鼠标在矩形内部的位置 
(defun GetMouseDirection (pt ll ru / center relX relY) 
  (setq center (list (/ (+ (car ll) (car ru)) 2.0) 
                     (/ (+ (cadr ll) (cadr ru)) 2.0) 
                     (caddr ll))) 
   
  ;;计算相对位置 
  (setq relX (- (car pt) (car center)) 
        relY (- (cadr pt) (cadr center))) 
   
  ;;根据相对位置判断方向 
  (cond 
    ((and (> (abs relY) (abs relX)) (> relY 0)) "top")     ;;上部 
    ((and (> (abs relY) (abs relX)) (< relY 0)) "bottom")  ;;下部 
    ((and (> (abs relX) (abs relY)) (> relX 0)) "right")   ;;右侧 
    ((and (> (abs relX) (abs relY)) (< relX 0)) "left")    ;;左侧 
    (t "top")  ;;默认上部 
  ) 
) 
 
;;绘制偏移矩形 
(defun DrawOffsetRect (ll ru direction thickness move_dist / newLL newRU newLU newRL) 
  (cond 
    ((= direction "top")    ;;上部矩形 - 向下移动 
      (setq newLL (list (car ll) (- (- (cadr ru) thickness) move_dist) 0) 
            newRU (list (car ru) (- (cadr ru) move_dist) 0)) 
    ) 
    ((= direction "bottom") ;;下部矩形 - 向上移动 
      (setq newLL (list (car ll) (+ (cadr ll) move_dist) 0) 
            newRU (list (car ru) (+ (+ (cadr ll) thickness) move_dist) 0)) 
    ) 
    ((= direction "left")   ;;左侧矩形 - 向右移动 
      (setq newLL (list (+ (car ll) move_dist) (cadr ll) 0) 
            newRU (list (+ (+ (car ll) thickness) move_dist) (cadr ru) 0)) 
    ) 
    ((= direction "right")  ;;右侧矩形 - 向左移动 
      (setq newLL (list (- (- (car ru) thickness) move_dist) (cadr ll) 0) 
            newRU (list (- (car ru) move_dist) (cadr ru) 0)) 
    ) 
  ) 
   
  (setq newLU (list (car newLL) (cadr newRU) 0) 
        newRL (list (car newRU) (cadr newLL) 0)) 
   
  ;;绘制偏移矩形（用不同颜色显示，比如绿色） 
  (grdraw newLL newLU 3) 
  (grdraw newLU newRU 3) 
  (grdraw newRU newRL 3) 
  (grdraw newRL newLL 3) 
) 
 
;;创建偏移矩形 
(defun CreateOffsetRect (ll ru direction thickness move_dist / newLL newRU) 
  (cond 
    ((= direction "top")    ;;上部矩形 - 向下移动 
      (setq newLL (list (car ll) (- (- (cadr ru) thickness) move_dist) 0) 
            newRU (list (car ru) (- (cadr ru) move_dist) 0)) 
    ) 
    ((= direction "bottom") ;;下部矩形 - 向上移动 
      (setq newLL (list (car ll) (+ (cadr ll) move_dist) 0) 
            newRU (list (car ru) (+ (+ (cadr ll) thickness) move_dist) 0)) 
    ) 
    ((= direction "left")   ;;左侧矩形 - 向右移动 
      (setq newLL (list (+ (car ll) move_dist) (cadr ll) 0) 
            newRU (list (+ (+ (car ll) thickness) move_dist) (cadr ru) 0)) 
    ) 
    ((= direction "right")  ;;右侧矩形 - 向左移动 
      (setq newLL (list (- (- (car ru) thickness) move_dist) (cadr ll) 0) 
            newRU (list (- (car ru) move_dist) (cadr ru) 0)) 
    ) 
  ) 
   
  (command "_.rectang" "_non" newLL "_non" newRU) 
) 
 
;;删除识别内空的矩形 
(defun c:DeleteInnerRects (/ ss i ent obj minpt maxpt bounds allrects outer inner todelete) 
  (princ "\n选择要清理的矩形集合: ") 
  (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4))))  ; 选择多段线矩形 
   
  (if ss 
    (progn 
      (setq allrects '()) 
       
      ;;收集所有矩形及其边界 
      (setq i 0) 
      (while (
        (setq ent (ssname ss i)) 
        (setq obj (vlax-ename->vla-object ent)) 
        (vla-getboundingbox obj 'minpt 'maxpt) 
        (setq minpt (vlax-safearray->list minpt) 
              maxpt (vlax-safearray->list maxpt)) 
         
        (setq allrects (cons (list ent minpt maxpt) allrects)) 
        (setq i (1+ i)) 
      ) 
       
      ;;找出内空的矩形（被其他矩形完全包含的矩形） 
      (setq todelete '()) 
      (foreach rect1 allrects 
        (foreach rect2 allrects 
          (if (and (not (equal (car rect1) (car rect2)))  ; 不是同一个矩形 
                   (IsInside (cadr rect1) (caddr rect1)  ; rect1完全在rect2内部 
                            (cadr rect2) (caddr rect2))) 
            (setq todelete (cons (car rect1) todelete)) 
          ) 
        ) 
      ) 
       
      ;;删除内空的矩形 
      (if todelete 
        (progn 
          (setq todelete (vl-remove-duplicates todelete))  ; 去除重复项 
          (foreach ent todelete 
            (entdel ent) 
          ) 
          (princ (strcat "\n删除了 " (itoa (length todelete)) " 个内空矩形")) 
        ) 
        (princ "\n未找到内空矩形") 
      ) 
    ) 
    (princ "\n未选择到矩形") 
  ) 
  (princ) 
) 
 
;;判断矩形1是否完全在矩形2内部 
(defun IsInside (min1 max1 min2 max2) 
  (and 
    (>= (car min1) (car min2)) 
    (>= (cadr min1) (cadr min2)) 
    (<= (car max1) (car max2)) 
    (<= (cadr max1) (cadr max2)) 
  ) 
) 
 
(princ "\n动态框绘制程序加载完成，输入 DD 运行，输入 DeleteInnerRects 删除内空矩形") 
(princ)

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

[源码] 动态加矩形