求一个画中心矩形的代码

2369198685 · 发表于前天 00:54

本人对代码小白，求一个画中心矩形的代码，不胜感激

xj6019 · 发表于前天 08:18

(defun c:NM (/ center h pt1 pt2 pt3 pt4 w)
(setq w (getreal "\n请输入矩形的宽度: "))
(if (not w)
(progn
(princ "\n未输入宽度，命令取消。")
(exit)
)
)
(setq h (getreal "\n请输入矩形的高度: "))
(if (not h)
(progn
(princ "\n未输入高度，命令取消。")
(exit)
)
)
(setq center (cadr(grread 3)) )
(setq pt1 (list (- (car center) (/ w 2)) (+ (cadr center) (/ h 2))))
(setq pt2 (list (+ (car center) (/ w 2)) (+ (cadr center) (/ h 2))))
(setq pt3 (list (+ (car center) (/ w 2)) (- (cadr center) (/ h 2))))
(setq pt4 (list (- (car center) (/ w 2)) (- (cadr center) (/ h 2))))
(command "_.pline" pt1 pt2 pt3 pt4 pt1 "")
(command "_.move" (entlast) "" center pause)
(princ)
)

lailaifa · 发表于前天 08:19

(defun c:tt ( / cen w h p1 p2 p3 p4)
  ; 获取宽度和高度
  (setq w (getdist "\n输入矩形宽度: "))
  (setq h (getdist "\n输入矩形高度: "))

; 获取中心点
  (setq cen (getpoint "\n指定矩形中心点: "))

  ; 计算四个角点坐标
  (setq p1 (list (- (car cen) (/ w 2)) (+ (cadr cen) (/ h 2)))) ; 左上角
  (setq p2 (list (+ (car cen) (/ w 2)) (+ (cadr cen) (/ h 2)))) ; 右上角
  (setq p3 (list (+ (car cen) (/ w 2)) (- (cadr cen) (/ h 2)))) ; 右下角
  (setq p4 (list (- (car cen) (/ w 2)) (- (cadr cen) (/ h 2)))) ; 左下角
  (setvar "OSMODE" 0);关闭捕捉
  ; 绘制闭合多段线
  (command "_.pline" p1 p2 p3 p4 "_c")
(setvar"osmode"15359);恢复捕捉
  (princ)
)

尘缘一生 · 发表于前天 09:12

本帖最后由尘缘一生于 2025-2-19 09:14 编辑

尽量少用COMMAND,下面是SLdesign V3.0 三领设计的代码...

;;entmake 多义线，带宽度，开关闭合-----(一级)------
;lst 点表 , plwid 线宽=num，dxf70 是否闭合= t 闭合,
(defun makelwpolyline (lst plwid dxf70 / pt)
(entmake
(append
(list
(cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline")
(cons 90 (length lst))
(if dxf70
(cons 70 1)
(cons 70 0)
)
(if plwid
(cons 43 plwid)
(cons 43 0)
)
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)
;点表生成多段线--------(一级)-------
;线宽=nil，线宽为0 ;是否闭合=nil，不闭合 ;图层=nil，为当前图层 ;颜色=nil，为当前图层颜色 ;线型比例=nil，为1
;(slch:lwpolyline 点表是否闭合线宽图层颜色线型比例)
;(slch:lwpolyline (list (1 2) (2 3)) t 2 "中心线" 6 5)
(defun slch:lwpolyline (lst dxf70 plwid lay lwplcol lwplbili / pt)
(entmake
(append
(list
(cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline")
(cons 90 (length lst)) ;点表
(if dxf70
(cons 70 1) ;闭合与不闭合
(cons 70 0)
)
(if plwid
(cons 43 plwid) ;线宽
(cons 43 0)
)
(if lay
(cons 8 lay) ;图层
(cons 8 (getvar "CLAYER"))
)
(if lay
(cons 6 (vla-get-linetype (vla-item *LAYS* lay)))
(cons 6 "CONTINUOUS")
)
(if lwplcol
(cons 62 lwplcol) ;颜色
(cons 62 256)
)
(if lwplbili
(cons 48 lwplbili) ;线型比例
(cons 48 (* 0.01 (getvar "DIMLFAC")))
)
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)
;;画0矩形框-----------
(defun c:kua00 (/ p1 p2)
(setq p1 (getpoint (slmsg "\n 第一角点:" "\n 材à翴:" "\n First corner:")) p2 (getcorner p1 (slmsg "\n 第二角点:" "\n 材à翴:" "\n Second corner:")))
(makelwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) 0 t)
(princ)
)
;;画0.45框---------
(defun c:gjk (/ p1 p2)
(setq p1 (getpoint (slmsg "\n 第一角点:" "\n 材à翴:" "\n First corner:")) p2 (getcorner p1 (slmsg "\n 第二角点:" "\n 材à翴:" "\n Other corner:")))
(slch:lwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) t (* SLBL 0.45) (slmsg "钢筋" "葵惮" "steelbar") 1 nil)
)

;;entmake 多义线，带宽度，开关闭合-----(一级)------ 
;lst 点表 , plwid 线宽=num，dxf70 是否闭合= t 闭合, 
(defun makelwpolyline (lst plwid dxf70 / pt) 
  (entmake 
    (append 
      (list 
        (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") 
        (cons 90 (length lst)) 
        (if dxf70 
          (cons 70 1) 
          (cons 70 0) 
        ) 
        (if plwid 
          (cons 43 plwid) 
          (cons 43 0) 
        ) 
      ) 
      (mapcar '(lambda (pt) (cons 10 pt)) lst) 
    ) 
  ) 
) 
;点表生成多段线--------(一级)------- 
;线宽=nil，线宽为0  ;是否闭合=nil，不闭合 ;图层=nil，为当前图层 ;颜色=nil，为当前图层颜色  ;线型比例=nil，为1 
;(slch:lwpolyline 点表 是否闭合 线宽 图层 颜色 线型比例) 
;(slch:lwpolyline (list (1 2) (2 3)) t 2 "中心线" 6 5) 
(defun slch:lwpolyline (lst dxf70 plwid lay lwplcol lwplbili / pt) 
  (entmake 
    (append 
      (list 
        (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") 
        (cons 90 (length lst)) ;点表 
        (if dxf70 
          (cons 70 1)          ;闭合与不闭合 
          (cons 70 0) 
        ) 
        (if plwid 
          (cons 43 plwid)      ;线宽 
          (cons 43 0) 
        ) 
        (if lay 
          (cons 8 lay)         ;图层 
          (cons 8 (getvar "CLAYER")) 
        ) 
        (if lay 
          (cons 6 (vla-get-linetype (vla-item *LAYS* lay))) 
          (cons 6 "CONTINUOUS") 
        ) 
        (if lwplcol 
          (cons 62 lwplcol)    ;颜色 
          (cons 62 256) 
        ) 
        (if lwplbili 
          (cons 48 lwplbili)   ;线型比例 
          (cons 48 (* 0.01 (getvar "DIMLFAC"))) 
        ) 
      ) 
      (mapcar '(lambda (pt) (cons 10 pt)) lst) 
    ) 
  ) 
) 
;;画0矩形框----------- 
(defun c:kua00 (/ p1 p2) 
  (setq p1 (getpoint (slmsg "\n 第一角点:" "\n 材à翴:" "\n First corner:")) p2 (getcorner p1 (slmsg "\n 第二角点:" "\n 材à翴:" "\n Second corner:"))) 
  (makelwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) 0 t) 
  (princ) 
) 
;;画0.45框--------- 
(defun c:gjk (/ p1 p2) 
  (setq p1 (getpoint (slmsg "\n 第一角点:" "\n 材à翴:" "\n First corner:")) p2 (getcorner p1 (slmsg "\n 第二角点:" "\n 材à翴:" "\n Other corner:"))) 
  (slch:lwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) t (* SLBL 0.45) (slmsg "钢筋" "葵惮" "steelbar") 1 nil) 
)

lailaifa · 发表于前天 09:22

尘缘一生发表于 2025-2-19 09:12
尽量少用COMMAND,下面是SLdesign V3.0 三领设计的代码...

这么长啊，函数还不齐

尘缘一生 · 发表于前天 09:46

lailaifa 发表于 2025-2-19 09:22
这么长啊，函数还不齐

;;画0矩形框-----------
(defun c:kua00 (/ p1 p2)
(setq p1 (getpoint "\n 第一角点:") p2 (getcorner p1"\n 第二角点:"))
(makelwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) 0 t)
(princ)
)
;;画0.45框---------
(defun c:gjk (/ p1 p2)
(setq p1 (getpoint ) p2 (getcorner p1 "\n 第二角点:"))
(slch:lwpolyline (list p1 (list (car p1) (cadr p2)) p2 (list (car p2) (cadr p1))) t (* SLBL 0.45) "钢筋" 1 nil)
)

函数并非独为此，属于内裤部分。
SLBL 是三领设计的比例常量，"钢筋" 是图层

2369198685 · 发表于前天 10:36

lailaifa 发表于 2025-2-19 08:19
(defun c:tt ( / cen w h p1 p2 p3 p4)
; 获取宽度和高度
(setq w (getdist "\n输入矩形宽度: "))
...

非常感谢谢大师的代码，明经有你更精彩

2369198685 · 发表于前天 10:38

xj6019 发表于 2025-2-19 08:18
(defun c:NM (/ center h pt1 pt2 pt3 pt4 w)
(setq w (getreal "\n请输入矩形的宽度: "))
(if (not w) ...

非常感谢谢大师的代码，明经有你更精彩

2369198685 · 发表于前天 10:40

尘缘一生发表于 2025-2-19 09:46
;;画0矩形框-----------
(defun c:kua00 (/ p1 p2)
(setq p1 (getpoint "\n 第一角点:") ...

非常感谢谢大师的代码，明经有你更精彩

paulpipi · 发表于昨天 15:27

感谢分享，收藏备用

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

求一个画中心矩形的代码

浏览过的版块