【K:GetEntInters】计算直线和实体的交点

kucha007

单纯用ssget栏选配合ssnamex得到的交点在某些T形线或虚线间隙的位置会漏掉交点

1. (setq SS (ssget "F" (list p1 p2)'((0 . "*LINE,ARC,CIRCLE"))))
   
2. (apply 'append (mapcar '(lambda (x) (mapcar 'cadr (cdddr x))) (ssnamex SS)));交点坐标
   

(setq SS (ssget "F" (list p1 p2)'((0 . "*LINE,ARC,CIRCLE"))))<br /> (apply 'append (mapcar '(lambda (x) (mapcar 'cadr (cdddr x))) (ssnamex SS)));交点坐标<br />

http://bbs.mjtd.com/thread-109701-1-1.html
在论坛找到了黄大师的函数，加以改进如下：
;虚线间隙通过全局比例先放大再缩小得到交点。就是有点奇葩...感觉就像是栏选的一个bug一样？
;和栏选线重叠的端点，单独收集再合并到交点列表

1. ;在直线的交点及重叠端点处画圆
   
2. (defun K:GetEntInters (/ DOC p1 p2 TmpEnt SS i en IntLst OnLinePts xx)
   
3.   (vl-load-com)
   
4.   (setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))
   
5.   (progn ;基础函数
   
6.     ;计算两实体的交点 by 自贡黄明儒
   
7.     (defun K:TwoEntInters (e1 e2 Flag / Lst NewLst)
   
8.       (setq Lst (vlax-invoke
   
9.                   (vlax-ename->vla-object e1)
   
10.                   'Intersectwith
    
11.                   (vlax-ename->vla-object e2)
    
12.                   Flag
    
13.                 )
    
14.       )
    
15.       (while Lst
    
16.         (setq NewLst (cons (list (car Lst) (cadr Lst) (caddr Lst)) NewLst))
    
17.         (setq Lst (cdddr Lst))
    
18.       )
    
19.       NewLst
    
20.     )
    
21.     ;删除列表中重复的元素(容差) by Lee Mac
    
22.     (defun K:UniqueFuzz (Lst Fuzz)
    
23.       (if Lst
    
24.         (cons
    
25.           (car Lst)
    
26.           (K:UniqueFuzz
    
27.             (vl-remove-if
    
28.               (function (lambda (x) (equal x (car Lst) Fuzz)))
    
29.               (cdr Lst)
    
30.             )
    
31.             Fuzz
    
32.           )
    
33.         )
    
34.       )
    
35.     )
    
36.     ;收集在线段P1P2上的所有对象端点
    
37.     (defun K:PtOnLineLst (SS p1 p2 / pt Lst)
    
38.       (setq Lst '());清空列表
    
39.       (setq Lst '());清空列表
    
40.       (repeat (setq i (sslength SS))
    
41.         (setq en (ssname SS (setq i (1- i))))
    
42.         (setq Lst
    
43.           (append
    
44.             (list
    
45.               (vlax-curve-getstartpoint (vlax-ename->vla-object en))
    
46.               (vlax-curve-getendpoint (vlax-ename->vla-object en))
    
47.             )
    
48.             Lst
    
49.           )
    
50.         )
    
51.       );收集端点坐标
    
52.       (vl-remove-if-not
    
53.           '(lambda (pt) (equal (distance p1 p2) (+ (distance pt p1) (distance pt p2)) 0.001))
    
54.           Lst
    
55.       );过滤掉不在直线上的端点
    
56.     )
    
57.   )
    
58.   (graphscr);返回图形交互界面
    
59.   (vla-startundomark DOC)
    
60.     (setq p1 (getpoint "\n→请输入栏选的第一点："))
    
61.     (if (setq p2 (getpoint p1 "\n→请输入栏选的第二点:"))
    
62.       (progn
    
63.         (setvar "LTSCALE" (* (getvar "LTSCALE") 100));全局比例放大
    
64.         (command "regen");刷新视图
    
65.         
    
66.         (setq SS (ssget "F" (list p1 p2) '((0 . "*LINE,ARC,CIRCLE"))))
    
67.         (setq OnLinePts (K:PtOnLineLst SS p1 p2));重叠的端点
    
68.         
    
69.         (setq TmpEnt
    
70.           (entmakex
    
71.             (list
    
72.               (cons 0 "LINE")
    
73.               (cons 10 (trans p1 1 0))
    
74.               (cons 11 (trans p2 1 0))
    
75.             )
    
76.           )
    
77.         );创建临时直线
    
78.         (setq IntLst '());空表
    
79.         (repeat (setq i (sslength SS))
    
80.           (setq en (ssname SS (setq i (1- i))))
    
81.           (setq IntLst (append (K:TwoEntInters TmpEnt en 0) IntLst))
    
82.         );收集交点列表
    
83.         (entdel TmpEnt);删除临时直线
    
84.         
    
85.         (setvar "LTSCALE" (/ (getvar "LTSCALE") 100));全局比例缩小
    
86.         (command "regen");刷新视图
    
87.         
    
88.         (setq IntLst  
    
89.           (vl-sort
    
90.             (K:UniqueFuzz (append OnLinePts IntLst) 0.01);;合并点表后去重
    
91.             '(lambda (x y) (< (distance (trans p1 1 0) x) (distance (trans p1 1 0) y))) ;距离越短的点排在前面
    
92.           );排序:离起点越近越排在前面
    
93.         )
    
94.         (foreach xx IntLst
    
95.           (entmake
    
96.             (list
    
97.               (cons 0 "CIRCLE")
    
98.               (cons 10 xx)
    
99.               (cons 40 2.0);半径2
    
100.               (cons 62 6);洋红色
     
101.             )
     
102.           )
     
103.         );绘制圆弧
     
104.       )
     
105.     )
     
106.   (vla-endundomark DOC)
     
107.   (princ)
     
108. )

;在直线的交点及重叠端点处画圆<br /> (defun K:GetEntInters (/ DOC p1 p2 TmpEnt SS i en IntLst OnLinePts xx) <br />   (vl-load-com)<br />   (setq DOC (vla-get-ActiveDOCument (vlax-get-acad-object)))<br />   (progn ;基础函数<br />     ;计算两实体的交点 by 自贡黄明儒<br />     (defun K:TwoEntInters (e1 e2 Flag / Lst NewLst) <br />       (setq Lst (vlax-invoke <br />                   (vlax-ename->vla-object e1)<br />                   'Intersectwith<br />                   (vlax-ename->vla-object e2)<br />                   Flag<br />                 )<br />       )<br />       (while Lst <br />         (setq NewLst (cons (list (car Lst) (cadr Lst) (caddr Lst)) NewLst))<br />         (setq Lst (cdddr Lst))<br />       )<br />       NewLst<br />     )<br />     ;删除列表中重复的元素(容差) by Lee Mac<br />     (defun K:UniqueFuzz (Lst Fuzz) <br />       (if Lst <br />         (cons <br />           (car Lst)<br />           (K:UniqueFuzz <br />             (vl-remove-if <br />               (function (lambda (x) (equal x (car Lst) Fuzz)))<br />               (cdr Lst)<br />             )<br />             Fuzz<br />           )<br />         )<br />       )<br />     )<br />     ;收集在线段P1P2上的所有对象端点<br />     (defun K:PtOnLineLst (SS p1 p2 / pt Lst)<br />       (setq Lst '());清空列表<br />       (setq Lst '());清空列表<br />       (repeat (setq i (sslength SS)) <br />         (setq en (ssname SS (setq i (1- i))))<br />         (setq Lst <br />           (append <br />             (list<br />               (vlax-curve-getstartpoint (vlax-ename->vla-object en))<br />               (vlax-curve-getendpoint (vlax-ename->vla-object en))<br />             )<br />             Lst<br />           )<br />         )<br />       );收集端点坐标<br />       (vl-remove-if-not <br />           '(lambda (pt) (equal (distance p1 p2) (+ (distance pt p1) (distance pt p2)) 0.001))<br />           Lst<br />       );过滤掉不在直线上的端点<br />     )<br />   )<br />   (graphscr);返回图形交互界面<br />   (vla-startundomark DOC)<br />     (setq p1 (getpoint "\n→请输入栏选的第一点："))<br />     (if (setq p2 (getpoint p1 "\n→请输入栏选的第二点:")) <br />       (progn <br />         (setvar "LTSCALE" (* (getvar "LTSCALE") 100));全局比例放大<br />         (command "regen");刷新视图<br />         <br />         (setq SS (ssget "F" (list p1 p2) '((0 . "*LINE,ARC,CIRCLE"))))<br />         (setq OnLinePts (K:PtOnLineLst SS p1 p2));重叠的端点<br />         <br />         (setq TmpEnt <br />           (entmakex <br />             (list <br />               (cons 0 "LINE")<br />               (cons 10 (trans p1 1 0))<br />               (cons 11 (trans p2 1 0))<br />             )<br />           )<br />         );创建临时直线<br />         (setq IntLst '());空表<br />         (repeat (setq i (sslength SS)) <br />           (setq en (ssname SS (setq i (1- i))))<br />           (setq IntLst (append (K:TwoEntInters TmpEnt en 0) IntLst))<br />         );收集交点列表<br />         (entdel TmpEnt);删除临时直线<br />         <br />         (setvar "LTSCALE" (/ (getvar "LTSCALE") 100));全局比例缩小<br />         (command "regen");刷新视图<br />         <br />         (setq IntLst  <br />           (vl-sort <br />             (K:UniqueFuzz (append OnLinePts IntLst) 0.01);;合并点表后去重<br />             '(lambda (x y) (< (distance (trans p1 1 0) x) (distance (trans p1 1 0) y))) ;距离越短的点排在前面<br />           );排序:离起点越近越排在前面<br />         )<br />         (foreach xx IntLst<br />           (entmake <br />             (list <br />               (cons 0 "CIRCLE")<br />               (cons 10 xx)<br />               (cons 40 2.0);半径2<br />               (cons 62 6);洋红色<br />             )<br />           )<br />         );绘制圆弧<br />       )<br />     )<br />   (vla-endundomark DOC)<br />   (princ)<br /> )

hubeiwdlue

谢谢苦茶大神的分享。