关于长宽矩形问题

xiao88gang · 发表于 2021-9-14 17:00:54

论谈上找的画矩形的代码，觉得很好用，唯一不足的就是，能不能把起点和终点直接改为插入点，以矩形的中心为基准点。
哪位大侠给改一下代码，先谢谢啦。

(defun c:FF (/ d h p1 p2 p3 p1x p1y)
      (setq d (getdist"\n矩形长度:")  h (getdist"\n矩形高度:"))
      (while
            (setq       p1 (getpoint"\n选起点:") p2 (getcorner p1"\n选终点:")
                     p1x (car p1)
                     p1y (cadr p1)
                     ang (angle P1 P2))
            (cond
                     ((and (>= ang (* 0 pi)) (< ang (* 0.5 pi))) (setq p3 (list (+ p1x d) (+ p1y h))))
                     ((and (>= ang (* 0.5 pi)) (< ang (* 1 pi))) (setq p3 (list (- p1x d) (+ p1y h))))
                     ((and (>= ang (* 1 pi)) (< ang (* 1.5 pi))) (setq p3 (list (- p1x d) (- p1y h))))
                     ((and (>= ang (* 1.5 pi)) (< ang (* 2 pi))) (setq p3 (list (+ p1x d) (- p1y h))))
            )
            p3 (command "RECTANG" "non" p1 "non" p3))
      (princ)
)

kkq0305 · 发表于 2021-9-14 21:48:56

厉害了，这个解决方案。

xiao88gang · 发表于 2021-9-16 09:21:36

kkq0305 发表于 2021-9-14 21:48
厉害了，这个解决方案。

很不错的，就是这样的效果，改了哪里？

start4444 · 发表于 2021-9-16 10:24:54

(defun c:tt5 (/ d h key p1 p1x p1y p2 p3)
      (setq d (getdist"\n矩形长度:")  h (getdist"\n矩形高度:"))
      (while
            (setq p1 (getpoint"\n选取矩形中心点:"))
            (setq p1x (car p1) p1y (cadr p1) p2 (list (- p1x (* 0.5 d)) (+ p1y (* 0.5 h))) p3 (list (+ p1x (* 0.5 d)) (- p1y (* 0.5 h))))
            (command "RECTANG" "non" p2 "non" p3)
            (setq key (getstring  "是否旋转？[是(Y)/否(空格)]:"))
            (if (= key "y") (command "ROTATE" "l" "" "non" p1 90))
      )
      (princ)
)

kkq0305 · 发表于 2021-9-16 13:25:31

(defun c:tt ()
  (setq d (getdist "\n矩形长度:")
h (getdist "\n矩形高度:")
  )
  (while (setq pt (getpoint "\n输入矩形中心："))
(setq loop t)
(while loop
   (setq code (grread t 8))
   (cond ((= (car code) 5)
      (redraw)
      (makt pt (cadr code) d h nil)
      )
      ((= (car code) 3)
      (redraw)
      (makt pt (cadr code) d h nil)
      (setq loop nil)
      )
   )
)
(redraw)
(makt pt (cadr code) d h t)
  )
  (princ)
)
(defun makt (pt1 pt2 d h key)
  (if (or (< (* 0.25 pi) (angle pt1 pt2) (* 0.75 pi))
   (< (* 1.25 pi) (angle pt1 pt2) (* 1.75 pi))
   )
(setq d0 h
   h0 d
)
(setq d0 d
   h0 h
)
  )
  (if key
(entmake
   (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(62 . 3)
(cons 10
      (mapcar '+ (list (- (* 0.5 d0)) (- (* 0.5 h0))) pt1)
)
(cons 10
      (mapcar '+ (list (+ (* 0.5 d0)) (- (* 0.5 h0))) pt1)
)
(cons 10
      (mapcar '+ (list (+ (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
)
(cons 10
      (mapcar '+ (list (- (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
)
   )
)
(grvecs
   (list 1
      pt1
      pt2
      1
      (mapcar '+ (list (- (* 0.5 d0)) (- (* 0.5 h0))) pt1)
      (mapcar '+ (list (+ (* 0.5 d0)) (- (* 0.5 h0))) pt1)
      1
      (mapcar '+ (list (+ (* 0.5 d0)) (- (* 0.5 h0))) pt1)
      (mapcar '+ (list (+ (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
      1
      (mapcar '+ (list (+ (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
      (mapcar '+ (list (- (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
      1
      (mapcar '+ (list (- (* 0.5 d0)) (+ (* 0.5 h0))) pt1)
      (mapcar '+ (list (- (* 0.5 d0)) (- (* 0.5 h0))) pt1)
   )
)
  )
)

趣意人生 · 发表于 2021-9-16 14:39:16

回复收藏学习！

alexmai · 发表于 2021-9-18 21:35:09

画矩形，还是默认的好，(command "RECTANG" pause "d")

zmzk · 发表于 2025-2-4 09:19:13

收藏，学习。留痕

xyp1964 · 发表于 2025-2-4 10:06:41

(defun c:ff ()
"画矩形"
(defun udist (bit kwd msg def bpt / inp)
(if def(setq msg(strcat"\n"msg"<"(rtos def)">: ")bit(* 2(fix(/ bit 2))))
(setq msg(strcat"\n"msg": "))
)
(initget bit kwd)
(setq inp(if bpt(getdist msg bpt)(getdist msg)))
(if inp inp def)
)
(or d(setq d 1000.))
(or h(setq h 1000.))
(setq d (Udist 7 "" "矩形长度<输入或鼠标直接量取>" d nil))
(setq h (Udist 7 "" "矩形高度<输入或鼠标直接量取>" h nil))
(while (setq p0 (getpoint "\n矩形中心为<退出>: "))
(setq a (list (* d 0.5) (* h 0.5))
p1 (mapcar '(lambda (x y) (- x y)) p0 a)
p2 (mapcar '(lambda (x y) (+ x y)) p0 a)
)
(command "rectang" "non" p1 "non" p2)
)
(princ)
)

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

[讨论] 关于长宽矩形问题

本帖子中包含更多资源

点评

评分