求写一个矩形画叉插件

ajunseo · 发表于 2021-6-20 10:20:47

本帖最后由 ajunseo 于 2021-6-20 10:30 编辑

求写一个矩形画叉插件，中间矩形虚线，8号色

chenbh2 · 发表于 2021-9-13 14:08:04

(command "RECTANGLE" "non" (setq p1 (getpoint "\n点1:")) "non" (setq p2 (getcorner p1 "\n点2:")) "line" "non" p1 "non" p2 "" "line" "non" (list (car p1) (cadr p2)) "non" (list (car p2) (cadr p1)) "")

xj6019 · 发表于 2021-6-20 11:22:01

(DEFUN C:CRE (/ OLD_LAY SS I S ENT PT LEN))
(vl-load-com)
(setq old_lay (getvar "clayer"))
(if (not (tblsearch "layer" "HIDDEN"))
(command "._layer" "m" "HIDDEN" "c" "8" "" "lt" "HIDDEN" "" "LW"
      "0.05" "" "")
   )
   (setvar "clayer" "HIDDEN")
(setq ss (ssget ":S" '((0 . "LWPOLYLINE"))))
(setq i 0 s nil)
(if ss (progn
      (repeat (sslength ss)
         (setq ent (entget (ssname ss i)))
         (if (= -1 (vlax-get (vlax-ename->vla-object (ssname ss i)) 'closed))
            (progn
            (foreach lst ent
                  (if (= 10 (car lst))
                  (setq s (append s (list (cdr lst))))
                  )
            )
            (setq pt 0)
            (setq len (length s))
            (if (= len 4) (setq len 2))
            (while (> len pt)
            (command "LINE" (nth pt s) (nth (if (>= (+ 2 pt) (length s))(- (+ 2 pt) (length s)) (+ 2 pt)) s) "")
            (setq pt (1+ pt))
            )
            (setq s nil)
         )
         (princ "\n所选多段线不闭合.")
         )
         (setq i (1+ i))
      )
      )
      (princ "\n未选择多段线.")
)
(setvar "clayer" old_lay)
(princ)
)

烟盒迷唇 · 发表于 2021-6-20 11:43:03

(defun c:tt (/ p1 p2 p3 p4)
(setq p1 (getpoint "\n矩形插入点：")
p3 (getpoint p1 "\n对角点：")
p2 (list (car p3) (cadr p1))
p4 (list (car p1) (cadr p3))
)
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(70 . 1)
'(90 . 5)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
(cons 10 p1)
)
  )
  (entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 2)
'(6 . "DASHED")
'(62 . 8)
(cons 10 p1)
(cons 10 p3)
)
  )
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 2)
'(6 . "DASHED")
'(62 . 8)
(cons 10 p2)
(cons 10 p4)
)
  )
(princ)
)

mokson · 发表于 2021-6-20 14:01:34

我也一直想有这样的方法，现在终于实现了。

ajunseo · 发表于 2021-6-20 18:11:02

烟盒迷唇发表于 2021-6-20 11:43
(defun c:tt (/ p1 p2 p3 p4)
(setq p1 (getpoint "\n矩形插入点：")
p3 (getpoint p1 "\n对角点：") ...

好像用不了，可以画出矩形，但没有叉！

ajunseo · 发表于 2021-6-20 18:13:01

xj6019 发表于 2021-6-20 11:22
(DEFUN C:CRE (/ OLD_LAY SS I S ENT PT LEN))
(vl-load-com)
(setq old_lay (getvar "clayer"))

加载后显示语法错误呢！

xj6019 · 发表于 2021-6-20 18:20:48

ajunseo 发表于 2021-6-20 18:13
加载后显示语法错误呢！

(DEFUN C:CRE (/ OLD_LAY SS I S ENT PT LEN)
(vl-load-com)
(setq old_lay (getvar "clayer"))
(if (not (tblsearch "layer" "HIDDEN"))
(command "._layer" "m" "HIDDEN" "c" "8" "" "lt" "HIDDEN" "" "LW"
      "0.05" "" "")
               )
               (setvar "clayer" "HIDDEN")
(setq ss (ssget ":S" '((0 . "LWPOLYLINE"))))
(setq i 0 s nil)
(if ss (progn
      (repeat (sslength ss)
         (setq ent (entget (ssname ss i)))
         (if (= -1 (vlax-get (vlax-ename->vla-object (ssname ss i)) 'closed))
            (progn
            (foreach lst ent
                  (if (= 10 (car lst))
                  (setq s (append s (list (cdr lst))))
                  )
            )
            (setq pt 0)
            (setq len (length s))
            (if (= len 4) (setq len 2))
            (while (> len pt)
            (command "LINE" (nth pt s) (nth (if (>= (+ 2 pt) (length s))(- (+ 2 pt) (length s)) (+ 2 pt)) s) "")
            (setq pt (1+ pt))
            )
            (setq s nil)
         )
         (princ "\n所选多段线不闭合.")
         )
         (setq i (1+ i))
      )
      )
      (princ "\n未选择多段线.")
)
(setvar "clayer" old_lay)
(princ)
)

ajunseo · 发表于 2021-6-20 18:34:01

xj6019 发表于 2021-6-20 18:20
(DEFUN C:CRE (/ OLD_LAY SS I S ENT PT LEN)
(vl-load-com)
(setq old_lay (getvar "clayer"))

输入命令后，显示参数太少呢！

paulpipi · 发表于 2021-6-20 19:15:11

烟盒迷唇 · 发表于 2021-6-20 19:18:13

ajunseo 发表于 2021-6-20 18:11
好像用不了，可以画出矩形，但没有叉！

你的CAD有问题吧，我都测试过了没问题

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

[提问] 求写一个矩形画叉插件

本帖子中包含更多资源