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)
页:
1
[2]