画矩形小程序，可以选基点，画完可以移动旋转
本帖最后由 Qwer1243 于 2025-3-21 08:21 编辑用deepseek调试的画矩形小程序，支持选择基点（左上角，上边中点，形心点），选择基点过程中还支持水平和竖直翻转，画完矩形后可以选择移动和旋转操作
特别感谢zml84 的支持对象捕捉的grread函数
(defun c:e2 (/ *error* base_pt basept_type draw_l1 draw_l2 flip_h flip_v gr half_l1 half_l2 l1 l2 new_pt oldecho option osm ospt pt_右上 pt_右下 pt_左上 pt_左下 pt1 ptlst ref_pt target_pt)
;; 保存原始系统设置
(setq oldecho (getvar "cmdecho"))
(setq osm (getvar "osmode"))
(setvar "cmdecho" 0)
;; 错误处理函数
(defun *error* (msg)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n错误: " msg))
)
(setvar "osmode" osm)
(setvar "cmdecho" oldecho)
(princ)
)
;; 获取基本参数
(setq l1 (getdist "\n请输入矩形长："))
(setq l2 (getdist "\n请输入矩形宽："))
(setvar "osmode" 14847);; 删除这行代码
(setq basept_type "T");; 默认基点为左上角
(setq flip_h nil) ;; 水平翻转标志
(setq flip_v nil) ;; 垂直翻转标志
;; 动态预览循环
(princ "\n指定基点 (T=左上角/M=上中点/C=形心) H=水平翻转 V=垂直翻转: ")
(while (and (setq gr (grread t 15 0))
(/= (car gr) 3)
(/= (car gr) 25))
(redraw);; 清除之前的图形
;; 处理键盘输入（兼容大小写）
(if (= (car gr) 2)
(cond
;; 基点类型切换
((member (cadr gr) '(84 116)) (setq basept_type "T")); T/t
((member (cadr gr) '(77 109)) (setq basept_type "M")); M/m
((member (cadr gr) '(67 99))(setq basept_type "C")); C/c
;; 翻转操作
((member (cadr gr) '(72 104)) (setq flip_h (not flip_h))) ; H/h 水平翻转
((member (cadr gr) '(86 118)) (setq flip_v (not flip_v))) ; V/v 垂直翻转
)
)
;; 处理鼠标移动
(if (= (car gr) 5)
(progn
;; 调用对象捕捉功能获取点
(setq pt1 (cadr gr))
(if (setq ospt (GET-OSPOINT pt1))
(progn
;; 绘制捕捉点的靶标
(apply 'DRAW-ATPOINT ospt)
(setq pt1 (car ospt))
)
)
;; 根据翻转状态计算实际尺寸
(setq draw_l1 (* l1 (if flip_h -1 1))
draw_l2 (* l2 (if flip_v -1 1)))
;; 根据基点类型计算顶点
(cond
;; 左上角基点
((= basept_type "T")
(setq ptlst (list
(polar pt1 (* pi 1.5) draw_l2); 左下角
pt1 ; 左上角
(polar pt1 0 draw_l1) ; 右上角
(polar (polar pt1 0 draw_l1) (* pi 1.5) draw_l2) ; 右下角
)))
;; 上中点基点
((= basept_type "M")
(setq half_l1 (/ draw_l1 2.0))
(setq pt_左上 (polar pt1 pi half_l1)); 左上角
(setq pt_右上 (polar pt1 0 half_l1)) ; 右上角
(setq pt_右下 (polar pt_右上 (* pi 1.5) draw_l2)) ; 右下角
(setq pt_左下 (polar pt_左上 (* pi 1.5) draw_l2)) ; 左下角
(setq ptlst (list pt_左上 pt_右上 pt_右下 pt_左下)))
;; 形心基点
((= basept_type "C")
(setq half_l1 (/ draw_l1 2.0)
half_l2 (/ draw_l2 2.0))
(setq pt_左上 (polar (polar pt1 pi half_l1) (/ pi 2) half_l2)) ; 左上角
(setq pt_右上 (polar (polar pt1 0 half_l1) (/ pi 2) half_l2)) ; 右上角
(setq pt_右下 (polar (polar pt1 0 half_l1) (* pi 1.5) half_l2)) ; 右下角
(setq pt_左下 (polar (polar pt1 pi half_l1) (* pi 1.5) half_l2)) ; 左下角
(setq ptlst (list pt_左上 pt_右上 pt_右下 pt_左下)))
)
;; 绘制动态预览（红色）
(grvecs
(cons 1
(list
(nth 0 ptlst) (nth 1 ptlst)
(nth 1 ptlst) (nth 2 ptlst)
(nth 2 ptlst) (nth 3 ptlst)
(nth 3 ptlst) (nth 0 ptlst)
)
)
)
)
)
)
;; 确认绘制时清除预览
(if (= (car gr) 3)
(progn
(command "_.rectang"
"_non" (nth 0 ptlst); 第一个对角点
"_non" (nth 2 ptlst); 第二个对角点
)
(redraw) ; 强制刷新屏幕清除临时图形
)
)
;; 恢复系统设置
(setvar "osmode" osm)
(setvar "cmdecho" oldecho)
;; 增加移动和旋转选项
(initget "M R"); 使用 initget 定义选项
(setq option (getkword "\n选择操作 [移动/旋转]<确认>: "))
(setq base_pt pt1)
(cond
;; 移动
((= option "M")
(setq target_pt (getpoint base_pt "\n指定目标点: "))
(command "_.move" "_last" "" base_pt target_pt)
)
;; 旋转
((= option "R")
(setq ref_pt (getpoint base_pt "\n指定参照点: "))
(setq new_pt (getpoint base_pt "\n指定新角度点: "))
(command "_.rotate" "_last" "" base_pt "_reference" base_pt ref_pt new_pt)
)
;; 回车确认
((not option)
(princ "\n已确认，无操作。")
)
)
(princ)
)
;;;功能：支持对象捕捉的grread
;;; 代码源自fools
;;;日期：zml84 修改于 2009-05-20
(setq *LST*
'((1
"_end"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((1 -1) (1 1))
((1 1) (-1 1))
)
(2
"_mid"
((0 1.414) (-1.225 -0.707))
((-1.225 -0.707) (1.225 -0.707))
((1.225 -0.707) (0 1.414))
)
(4
"_cen"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
)
(8
"_nod"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
((-1 1) (1 -1))
((-1 -1) (1 1))
)
(16
"_qua"
((0 1.414) (-1.414 0))
((-1.414 0) (0 -1.414))
((0 -1.414) (1.414 0))
((1.414 0) (0 1.414))
)
(32
"_int"
((-1 1) (1 -1))
((-1 -1) (1 1))
((1 0.859) (-0.859 -1))
((-1 0.859) (0.859 -1))
((0.859 1) (-1 -0.859))
((-0.859 1) (1 -0.859))
)
(64
"_ins"
((-1 1) (-1 -0.1))
((-1 -0.1) (0 -0.1))
((0 -0.1) (0 -1.0))
((0 -1.0) (1 -1))
((1 -1) (1 0.1))
((1 0.1) (0 0.1))
((0 0.1) (0 1.0))
((0 1.0) (-1 1))
)
(128
"_per"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((0 -1) (0 0))
((0 0) (-1 0))
)
(256
"_tan"
((0 1) (-0.707 0.707))
((-0.707 0.707) (-1 0))
((-1 0) (-0.707 -0.707))
((-0.707 -0.707) (0 -1))
((0 -1) (0.707 -0.707))
((0.707 -0.707) (1 0))
((1 0) (0.707 0.707))
((0.707 0.707) (0 1))
((1 1) (-1 1))
)
(512
"_nea"
((-1 1) (1 -1))
((1 -1) (-1 -1))
((-1 -1) (1 1))
((1 1) (-1 1))
)
(1024 "_qui")
(2048
"_app"
((-1 1) (-1 -1))
((-1 -1) (1 -1))
((1 -1) (1 1))
((1 1) (-1 1))
((-1 1) (1 -1))
((-1 -1) (1 1))
)
(4096
"_ext"
((0.1 0) (0.13 0))
((0.2 0) (0.23 0))
((0.3 0) (0.33 0))
)
(8192
"_par"
((0 1) (-1 -1))
((1 1) (0 -1))
)
)
)
;;;=================================================================*
;;;功能：计算在当前对象捕捉设置情况下，指定点的对象捕捉点位 *
;;;思路：获取当前的对象捕捉模式；*
;;; 逐个使用osnap来尝试获取点位；*
;;; 比较点位距离指定点的距离，最近的即为结果。*
;;;返回：(捕捉到的点位 捕捉模式) *
;;; 捕捉模式为0表示，不捕捉。*
(defun GET-OSPOINT (PT / LST_JG OS N PT_NEW)
(setq LST_JG '()
OS (getvar "osmode")
)
(if(< 0 OS 16384)
(foreach N (reverse *LST*)
(if(and (= (logand OS (car N)) (car N))
(setq PT_NEW (osnap PT (cadr N)))
)
(setq
LST_JG (cons (list (distance PT_NEW PT)
PT_NEW
(car N)
)
LST_JG
)
)
)
)
(setq LST_JG (list (list 0 PT 0)))
)
;;根据距离大小排序
(if(> (length LST_JG) 1)
(setq LST_JG (vl-sort LST_JG
(function(lambda(E1 E2)
(< (car E1) (car E2))
)
)
)
)
)
;;返回
;;; (print LST_JG)
(cdr (car LST_JG))
)
;;;=================================================================*
;;;功能：在指定点绘制指定的靶标 *
;;;参数：PT -----要绘制的位置 *
;;; I-----捕捉模式单项值。例如：1 or 2 or 4 ... *
(defun DRAW-ATPOINT (PT I / SIZE COLOR MATRIX LST)
(foreach REAL '(-0.5 0 0.5)
(setq SIZE(* (+ (read (getenv "AutoSnapSize")) REAL)
(/ (getvar "VIEWSIZE")
(cadr (getvar "SCREENSIZE"))
)
)
COLOR (read (getenv "AutoSnapColor"))
)
(setq MATRIX (list (list SIZE 0.0 0.0 (car PT))
(list 0.0 SIZE 0.0 (cadr PT))
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0)
)
)
(and (setq LST (cddr (assoc I *LST*)))
(setq LST
(mapcar (function (lambda (X) (cons COLOR X))) LST)
)
(setq LST (apply 'append LST))
(grvecs LST MATRIX)
)
)
)
;;;=================================================================
zhangcn 发表于 2025-2-24 17:26
输入长和宽应该再简化为一步输入用 “，” “.” 间隔长和宽，会更人性化。
我是感觉按空格比输入逗号方便点，你可以修改一下代码，适用自己 输入长和宽应该再简化为一步输入用 “，” “.” 间隔长和宽，会更人性化。 じ☆v湫樉v☆ 发表于 2025-2-23 10:40
挺方便的，比自带的好用，支持一下
很好→很棒！很好~很棒！！很好……很棒！！！
很好→很吊！很好→很吊！很好→很吊！！！ 太强了，我何时才能如此优秀 很好→很吊！很好→很吊！很好→很吊！！！ 挺方便的，比自带的好用，支持一下 很好→很棒！很好~很棒！！很好……很棒！！！
页:
[1]
2