获取封闭矩形顶点坐标

kzd2004 · 发表于 2023-6-14 16:59

大佬们求助

我想获取封闭矩形顶点坐标，比方说当我鼠标点击矩形内部区域时自动生成对角线，其实我要的是点击内部区域获取顶点坐标，请高人指教，不是点选矩形对角点。

xyp1964 · 发表于 2023-8-12 07:49

(defun c:tt ()
 "画矩形内部对角线"
 (while (setq p0 (getpoint "\n拾取矩形内部点<退出>: "))
(bpoly p0)
(setq s1 (entlast))
(setq ptn (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget s1))
 ptn (mapcar 'cdr ptn)
)
(entdel s1)
(command "line" "non" (car ptn) "non" (caddr ptn) "")
(command "line" "non" (cadr ptn) "non" (cadddr ptn) "")
 )
 (princ)
)

lee50310 · 发表于 2023-8-14 07:12

depgfdepgf 发表于 2023-8-14 06:44
大佬非常的完美，是否可以增加按鼠标右键退.这样方便很多

已更新 (簡體版) drpl2_chs.fas ,(繁體版) drpl2_cht.fas
請重新下載

lee50310 · 发表于 2023-8-13 19:47

本帖最后由 lee50310 于 2023-8-16 00:12 编辑

已更新

最新版 : (簡體版) drpl3_chs.fas ,(繁體版) drpl3_cht.fas
1.修正鼠標越過垂直長條矩形框時 ,左右區域無法抓取問題
2.修正虛線  線型比例為默認                               日期:2023/8/15

執行指令:drpl
1.滑鼠移至目標區內 5個方位(上,下,中,左,右)  左擊鼠鍵==>繪製
2.離開程式==>右擊滑鼠鍵或滑鼠移至目標區外左擊鼠鍵

飞雪神光 · 发表于 2023-7-26 14:46

kzd2004 发表于 2023-7-26 14:04
你好，代码很好，我是小白，请问这个用什么命令能调出来？能把这个直接改成画对角线吗？谢谢你了。

命令就是TT

(defun c:tt (/ gr lmts loop p1 p2 p3 p4 pt s1 s2 s3 s4 screen ys yx zs zx)
(defun screen(/ c03 c08 c04 c05 c07 c06 c09 c01 c02);
(setq
c03 (trans (getvar "viewctr") 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c09 (/ (* c08 (car c04)) (cadr c04))
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
(setq loop t)
(while loop
(setq gr (grread t 15 0))
(cond
((= 5 (car gr))
(setq lmts (screen))
(setq pt (cadr gr))
(if(and
(setq S1 (ssget "F" (LIST pt (list (car pt) (cadadr lmts)))'((0 . "*line"))))
(setq S2 (ssget "F" (LIST pt (list (car pt) (cadar lmts)))'((0 . "*line"))))
(setq S3 (ssget "F" (LIST pt (list (caar lmts) (cadr pt)))'((0 . "*line"))))
(setq S4 (ssget "F" (LIST pt (list (caadr lmts)(cadr pt)))'((0 . "*line"))))
)
(progn
(setq P1 (trans (cadr(nth 3 (car (ssnamex S1)))) 0 1));上
(setq P2 (trans (cadr(nth 3 (car (ssnamex S2)))) 0 1));下
(setq P3 (trans (cadr(nth 3 (car (ssnamex S3)))) 0 1));左
(setq P4 (trans (cadr(nth 3 (car (ssnamex S4)))) 0 1));右
(setq
ys(list (car p4) (cadr p1))
yx(list (car p4) (cadr p2))
zx(list (car p3) (cadr p2))
zs(list (car p3) (cadr p1))
)
(redraw)
(grdraw zx zs 4)
(grdraw zs ys 4)
(grdraw ys yx 4)
(grdraw zx yx 4)
(grdraw zx ys 190)
(grdraw zs yx 190)
)
(redraw)
)
)
((= 3 (car gr))
(setq loop nil)
(redraw)
(entmake (list '(0 . "line")(cons 10 zx)(cons 11 ys)))
(entmake (list '(0 . "line")(cons 10 zs)(cons 11 yx)))
)
)
)
(princ)
)

(defun c:tt (/ gr lmts loop p1 p2 p3 p4 pt s1 s2 s3 s4 screen ys yx zs zx) 
  (defun screen(/ c03 c08 c04 c05 c07 c06 c09 c01 c02); 
    (setq   
      c03 (trans (getvar "viewctr") 1 2) 
      c08 (getvar "viewsize") 
      c04 (getvar "screensize") 
      c09 (/ (* c08 (car c04)) (cadr c04)) 
      c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
      c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
      c01 (trans c01 2 1) 
      c02 (trans c02 2 1) 
    ) 
    (list c01 c02) 
  ) 
  (setq loop t) 
  (while loop 
    (setq gr (grread t 15 0)) 
    (cond 
      ((= 5 (car gr)) 
        (setq lmts (screen)) 
        (setq pt (cadr gr)) 
        (if(and 
             (setq S1 (ssget "F" (LIST pt (list (car pt) (cadadr lmts)))'((0 . "*line")))) 
             (setq S2 (ssget "F" (LIST pt (list (car pt) (cadar  lmts)))'((0 . "*line")))) 
             (setq S3 (ssget "F" (LIST pt (list (caar lmts) (cadr pt)))'((0 . "*line")))) 
             (setq S4 (ssget "F" (LIST pt (list (caadr lmts)(cadr pt)))'((0 . "*line")))) 
           ) 
          (progn 
            (setq P1 (trans (cadr(nth 3 (car (ssnamex S1)))) 0 1));上 
            (setq P2 (trans (cadr(nth 3 (car (ssnamex S2)))) 0 1));下 
            (setq P3 (trans (cadr(nth 3 (car (ssnamex S3)))) 0 1));左 
            (setq P4 (trans (cadr(nth 3 (car (ssnamex S4)))) 0 1));右 
            (setq 
              ys(list (car p4) (cadr p1)) 
              yx(list (car p4) (cadr p2)) 
              zx(list (car p3) (cadr p2)) 
              zs(list (car p3) (cadr p1)) 
            ) 
            (redraw) 
            (grdraw zx zs 4) 
            (grdraw zs ys 4) 
            (grdraw ys yx 4) 
            (grdraw zx yx 4) 
            (grdraw zx ys 190) 
            (grdraw zs yx 190) 
          ) 
          (redraw) 
        ) 
      ) 
      ((= 3 (car gr)) 
        (setq loop nil) 
                                (redraw) 
                                (entmake (list '(0 . "line")(cons 10 zx)(cons 11 ys))) 
                                (entmake (list '(0 . "line")(cons 10 zs)(cons 11 yx))) 
      ) 
    ) 
  ) 
  (princ) 
)

you_boss · 发表于 2023-6-14 17:33

;;;获取曲线的顶点
(defun get_pline-vertexs (e / i v lst)
(setq i 0)
(while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)

dcl1214 · 发表于 2023-6-14 17:47

CGAL有这个算法，开源的

飞雪神光 · 发表于 2023-6-14 19:26

本帖最后由飞雪神光于 2023-6-15 20:24 编辑

(defun c:tt (/ )
(defun screen(/ c03 c08 c04 c05 c07 c06 c09 c01 c02);
(setq
c03 (trans (getvar "viewctr") 1 2)
c08 (getvar "viewsize")
c04 (getvar "screensize")
c09 (/ (* c08 (car c04)) (cadr c04))
c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08)))
c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08)))
c01 (trans c01 2 1)
c02 (trans c02 2 1)
)
(list c01 c02)
)
(setq loop t)
(while loop
(setq gr (grread t 15 0))
(cond
((= 5 (car gr))
(setq lmts (screen))
(setq pt (cadr gr))
(if(and
(setq S1 (ssget "F" (LIST pt (list (car pt) (cadadr lmts)))'((0 . "*line"))))
(setq S2 (ssget "F" (LIST pt (list (car pt) (cadar lmts)))'((0 . "*line"))))
(setq S3 (ssget "F" (LIST pt (list (caar lmts) (cadr pt)))'((0 . "*line"))))
(setq S4 (ssget "F" (LIST pt (list (caadr lmts)(cadr pt)))'((0 . "*line"))))
)
(progn
(setq P1 (trans (cadr(nth 3 (car (ssnamex S1)))) 0 1));上
(setq P2 (trans (cadr(nth 3 (car (ssnamex S2)))) 0 1));下
(setq P3 (trans (cadr(nth 3 (car (ssnamex S3)))) 0 1));左
(setq P4 (trans (cadr(nth 3 (car (ssnamex S4)))) 0 1));右
(setq
ys(list (car p4) (cadr p1))
yx(list (car p4) (cadr p2))
zx(list (car p3) (cadr p2))
zs(list (car p3) (cadr p1))
)
(redraw)
(grdraw zx zs 1)
(grdraw zs ys 2)
(grdraw ys yx 3)
(grdraw zx yx 4)
(grdraw zx ys 5)
(grdraw zs yx 6)
)
(redraw)
)
)
((= 3 (car gr))
(setq loop nil)
)
)
)
(princ)
)

(defun c:tt (/ ) 
  (defun screen(/ c03 c08 c04 c05 c07 c06 c09 c01 c02); 
    (setq   
      c03 (trans (getvar "viewctr") 1 2) 
      c08 (getvar "viewsize") 
      c04 (getvar "screensize") 
      c09 (/ (* c08 (car c04)) (cadr c04)) 
      c01 (list (- (car c03) (* 0.5 c09)) (- (cadr c03) (* 0.5 c08))) 
      c02 (list (+ (car c03) (* 0.5 c09)) (+ (cadr c03) (* 0.5 c08))) 
      c01 (trans c01 2 1) 
      c02 (trans c02 2 1) 
    ) 
    (list c01 c02) 
  ) 
  (setq loop t) 
  (while loop 
    (setq gr (grread t 15 0)) 
    (cond 
      ((= 5 (car gr)) 
        (setq lmts (screen)) 
        (setq pt (cadr gr)) 
        (if(and 
             (setq S1 (ssget "F" (LIST pt (list (car pt) (cadadr lmts)))'((0 . "*line")))) 
             (setq S2 (ssget "F" (LIST pt (list (car pt) (cadar  lmts)))'((0 . "*line")))) 
             (setq S3 (ssget "F" (LIST pt (list (caar lmts) (cadr pt)))'((0 . "*line")))) 
             (setq S4 (ssget "F" (LIST pt (list (caadr lmts)(cadr pt)))'((0 . "*line")))) 
           ) 
          (progn 
            (setq P1 (trans (cadr(nth 3 (car (ssnamex S1)))) 0 1));上 
            (setq P2 (trans (cadr(nth 3 (car (ssnamex S2)))) 0 1));下 
            (setq P3 (trans (cadr(nth 3 (car (ssnamex S3)))) 0 1));左 
            (setq P4 (trans (cadr(nth 3 (car (ssnamex S4)))) 0 1));右 
            (setq 
              ys(list (car p4) (cadr p1)) 
              yx(list (car p4) (cadr p2)) 
              zx(list (car p3) (cadr p2)) 
              zs(list (car p3) (cadr p1)) 
            ) 
            (redraw) 
            (grdraw zx zs 1) 
            (grdraw zs ys 2) 
            (grdraw ys yx 3) 
            (grdraw zx yx 4) 
            (grdraw zx ys 5) 
            (grdraw zs yx 6) 
          ) 
          (redraw) 
        ) 
      ) 
      ((= 3 (car gr)) 
        (setq loop nil) 
      ) 
    ) 
  ) 
  (princ) 
)

cq4920 · 发表于 2023-6-14 23:33

1.生成内轮廓，获取内轮廓所有顶点坐标，取最大最小点，根据最大最小点，生成对应镜像点，生成直线！
2.可以无视内轮廓中有其他图形，可以无视内轮廓形状，防止内伦敦顶点数量不为4.
3.增加判断.对于内轮廓顶点为4，但不是矩形的内轮廓，可以用曲线顶点依次获取，13-24分别直接绘制直线！

kzd2004 · 发表于 2023-6-15 08:08

本帖最后由 kzd2004 于 2023-6-15 15:34 编辑

飞雪神光发表于 2023-6-14 19:26

大佬，提示输入的列表有缺陷，请保存lsp文件发给我，成分感谢！

kzd2004 · 发表于 2023-6-15 08:13

本帖最后由 kzd2004 于 2023-6-15 08:14 编辑

cq4920 发表于 2023-6-14 23:33
1.生成内轮廓，获取内轮廓所有顶点坐标，取最大最小点，根据最大最小点，生成对应镜像点，生成直线！
2.可 ...

关键是生成内轮廓，获取内轮廓所有顶点坐标，这个代码不知道怎么编写，请大佬帮忙一下。

htlaser · 发表于 2023-6-15 08:44

本帖最后由 htlaser 于 2023-6-15 08:45 编辑

作者不详忘记了

[code=lisp](defun outcurvept (en / n l ls1 ls2 lo po a b p1 p2 p11 p22)
(setq ob (vlax-ename->vla-object en))
(setq ls1 (list(cons 0.0(vlax-curve-getstartpoint ob))))
(if (wcmatch (vla-get-objectname ob) "*Polyline")
(setq n 0
x(while ;x仅匹配setq格式用
(setq po(vlax-curve-getpointatparam ob (setq n (1+ n))))
(setq l (vlax-curve-getDistAtParam ob n))
(setq ls2(append ls2(list(cons l po))));距离+坐标
)
)
(setq l(vlax-curve-getDistAtParam ob (vlax-curve-getendparam ob))
ls2(list(cons l(vlax-curve-getendpoint ob)))
);line,spline,circle,arc,ellipse
)
(while
(setq p11(last ls1) p22(car ls2))
(setq a (car p11) b (- (car p22) a))
(setq p1 (cdr p11) p2(cdr p22))
(if (equal b(distance p1 p2) 1e-5);直线段不管
(setq ls2(cdr ls2) ls1(append ls1 (list p22)))
(setq lo (+(setq b(* b 0.5))a)
po(vlax-curve-getPointAtDist ob lo);中间点
x (if (< (* b 0.9999) (distance p1 po))
(setq ls2(cdr ls2) ls1(append ls1(list p22)))
(setq ls2 (cons(cons lo po)ls2))
)
)
)
);循环自适应
(mapcar 'cdr ls1)
)

[code=lisp](defun outcurvept (en / n l ls1 ls2 lo po a b p1 p2 p11 p22) 
  (setq ob (vlax-ename->vla-object en)) 
  (setq ls1 (list(cons 0.0(vlax-curve-getstartpoint ob))))   
  (if  (wcmatch (vla-get-objectname ob) "*Polyline") 
    (setq n 0 
        x(while ;x仅匹配setq格式用 
            (setq po(vlax-curve-getpointatparam ob (setq n  (1+ n)))) 
            (setq l  (vlax-curve-getDistAtParam ob n)) 
            (setq ls2(append ls2(list(cons l po))));距离+坐标 
        ) 
    ) 
    (setq l(vlax-curve-getDistAtParam ob (vlax-curve-getendparam ob)) 
      ls2(list(cons l(vlax-curve-getendpoint ob))) 
    );line,spline,circle,arc,ellipse 
  )   
  (while 
    (setq p11(last ls1)  p22(car ls2)) 
    (setq a  (car p11)  b  (- (car p22) a)) 
    (setq p1 (cdr p11)  p2(cdr p22)) 
    (if  (equal b(distance p1 p2) 1e-5);直线段不管 
      (setq ls2(cdr ls2) ls1(append ls1 (list p22))) 
      (setq lo (+(setq b(* b 0.5))a) 
          po(vlax-curve-getPointAtDist ob lo);中间点 
          x (if  (< (* b 0.9999) (distance p1 po)) 
                (setq ls2(cdr ls2) ls1(append ls1(list p22))) 
                (setq ls2 (cons(cons lo po)ls2)) 
            ) 
      )       
    ) 
  );循环自适应 
  (mapcar 'cdr ls1) 
)

[/code]

kzd2004 · 发表于 2023-6-15 15:32

htlaser 发表于 2023-6-15 08:44
作者不详忘记了[/code]

大佬，还是提示输入的列表有缺陷

，要不请保存lsp文件给我，成分感谢！

htlaser · 发表于 2023-6-15 16:59

kzd2004 发表于 2023-6-15 15:32
大佬，还是提示输入的列表有缺陷，要不请保存lsp文件给我，成分感谢！

(outcurvept (car (entsel "\n 拾取l轮廓: ")))

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

[源码] 获取封闭矩形顶点坐标

本帖子中包含更多资源

评分

点评

评分