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

回复收藏学习！:handshake

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)
)
页: [1]
查看完整版本: 关于长宽矩形问题