获取封闭矩形顶点坐标
大佬们求助我想获取封闭矩形顶点坐标，比方说当我鼠标点击矩形内部区域时自动生成对角线，其实我要的是点击内部区域获取顶点坐标，请高人指教，不是点选矩形对角点。
(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)
) depgfdepgf 发表于 2023-8-14 06:44
大佬非常的完美，是否可以增加按鼠标右键退.这样方便很多
已更新 (簡體版) drpl2_chs.fas ,(繁體版) drpl2_cht.fas
請重新下載 本帖最后由 lee50310 于 2023-8-16 00:12 编辑
已更新
最新版 : (簡體版) drpl3_chs.fas ,(繁體版) drpl3_cht.fas
1.修正鼠標越過垂直長條矩形框時 ,左右區域無法抓取問題
2.修正虛線線型比例為默認 日期:2023/8/15
執行指令:drpl
1.滑鼠移至目標區內 5個方位(上,下,中,左,右)左擊鼠鍵==>繪製
2.離開程式==>右擊滑鼠鍵 或 滑鼠移至目標區外 左擊鼠鍵
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) (cadarlmts)))'((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 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)
)
CGAL有这个算法，开源的 本帖最后由 飞雪神光 于 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) (cadarlmts)))'((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)
)
1.生成内轮廓，获取内轮廓所有顶点坐标，取最大最小点，根据最大最小点，生成对应镜像点，生成直线！
2.可以无视内轮廓中有其他图形，可以无视内轮廓形状，防止内伦敦顶点数量不为4.
3.增加判断.对于内轮廓顶点为4，但不是矩形的内轮廓，可以用曲线顶点依次获取，13-24分别直接绘制直线！ 本帖最后由 kzd2004 于 2023-6-15 15:34 编辑
飞雪神光 发表于 2023-6-14 19:26
大佬，提示输入的列表有缺陷，请保存lsp文件发给我，成分感谢！ 本帖最后由 kzd2004 于 2023-6-15 08:14 编辑
cq4920 发表于 2023-6-14 23:33
1.生成内轮廓，获取内轮廓所有顶点坐标，取最大最小点，根据最大最小点，生成对应镜像点，生成直线！
2.可 ...
关键是生成内轮廓，获取内轮廓所有顶点坐标，这个代码不知道怎么编写，请大佬帮忙一下。 本帖最后由 htlaser 于 2023-6-15 08:45 编辑
作者不详忘记了(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)
) htlaser 发表于 2023-6-15 08:44
作者不详忘记了
大佬，还是提示输入的列表有缺陷:'(，要不请保存lsp文件给我，成分感谢！ kzd2004 发表于 2023-6-15 15:32
大佬，还是提示输入的列表有缺陷，要不请保存lsp文件给我，成分感谢！
(outcurvept(car (entsel "\n 拾取l轮廓: ")))