【K:GetEntInters】计算直线和实体的交点
本帖最后由 kucha007 于 2023-4-15 09:53 编辑单纯用ssget栏选配合ssnamex得到的交点在某些T形线或虚线间隙的位置会漏掉交点
(setq SS (ssget "F" (list p1 p2)'((0 . "*LINE,ARC,CIRCLE"))))
(apply 'append (mapcar '(lambda (x) (mapcar 'cadr (cdddr x))) (ssnamex SS)));交点坐标
http://bbs.mjtd.com/thread-109701-1-1.html
在论坛找到了黄大师的函数，加以改进如下：
;虚线间隙通过全局比例先放大再缩小得到交点。就是有点奇葩...感觉就像是栏选的一个bug一样？
;和栏选线重叠的端点，单独收集再合并到交点列表
;在直线的交点及重叠端点处画圆
(defun K:GetEntInters (/ DOC p1 p2 TmpEnt SS i en IntLst OnLinePts xx)
(vl-load-com)
(setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))
(progn ;基础函数
;计算两实体的交点 by 自贡黄明儒
(defun K:TwoEntInters (e1 e2 Flag / Lst NewLst)
(setq Lst (vlax-invoke
(vlax-ename->vla-object e1)
'Intersectwith
(vlax-ename->vla-object e2)
Flag
)
)
(while Lst
(setq NewLst (cons (list (car Lst) (cadr Lst) (caddr Lst)) NewLst))
(setq Lst (cdddr Lst))
)
NewLst
)
;删除列表中重复的元素(容差) by Lee Mac
(defun K:UniqueFuzz (Lst Fuzz)
(if Lst
(cons
(car Lst)
(K:UniqueFuzz
(vl-remove-if
(function (lambda (x) (equal x (car Lst) Fuzz)))
(cdr Lst)
)
Fuzz
)
)
)
)
;收集在线段P1P2上的所有对象端点
(defun K:PtOnLineLst (SS p1 p2 / pt Lst)
(setq Lst '());清空列表
(setq Lst '());清空列表
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq Lst
(append
(list
(vlax-curve-getstartpoint (vlax-ename->vla-object en))
(vlax-curve-getendpoint (vlax-ename->vla-object en))
)
Lst
)
)
);收集端点坐标
(vl-remove-if-not
'(lambda (pt) (equal (distance p1 p2) (+ (distance pt p1) (distance pt p2)) 0.001))
Lst
);过滤掉不在直线上的端点
)
)
(graphscr);返回图形交互界面
(vla-startundomark DOC)
(setq p1 (getpoint "\n→请输入栏选的第一点："))
(if (setq p2 (getpoint p1 "\n→请输入栏选的第二点:"))
(progn
(setvar "LTSCALE" (* (getvar "LTSCALE") 100));全局比例放大
(command "regen");刷新视图
(setq SS (ssget "F" (list p1 p2) '((0 . "*LINE,ARC,CIRCLE"))))
(setq OnLinePts (K:PtOnLineLst SS p1 p2));重叠的端点
(setq TmpEnt
(entmakex
(list
(cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans p2 1 0))
)
)
);创建临时直线
(setq IntLst '());空表
(repeat (setq i (sslength SS))
(setq en (ssname SS (setq i (1- i))))
(setq IntLst (append (K:TwoEntInters TmpEnt en 0) IntLst))
);收集交点列表
(entdel TmpEnt);删除临时直线
(setvar "LTSCALE" (/ (getvar "LTSCALE") 100));全局比例缩小
(command "regen");刷新视图
(setq IntLst
(vl-sort
(K:UniqueFuzz (append OnLinePts IntLst) 0.01);;合并点表后去重
'(lambda (x y) (< (distance (trans p1 1 0) x) (distance (trans p1 1 0) y))) ;距离越短的点排在前面
);排序:离起点越近越排在前面
)
(foreach xx IntLst
(entmake
(list
(cons 0 "CIRCLE")
(cons 10 xx)
(cons 40 2.0);半径2
(cons 62 6);洋红色
)
)
);绘制圆弧
)
)
(vla-endundomark DOC)
(princ)
)
谢谢苦茶大神的分享。
页:
[1]