悬挂点 并智能连线

chenjieq1990

对论坛上的悬挂点程序进行了一定的修改，思路是这样的，源程序是在悬挂点处增加一个圆圈，本代码通过比较悬挂点之间的距离差，将距离差小于一定值的两个悬挂点通过直线连接，但是运行时候一直出错，看谁能帮忙看下。

悬挂点参考         http://bbs.mjtd.com/forum.php?mo ... D5%CF%DF&page=1

1. ;;悬空线检查
   
2. (defun c:tt (/ expert i lis n n100 nn pp pt1 pt2 pts rr ss ssd sslast)
   
3.   (vl-Load-COM)
   
4.   (setq ssd(ssget'((0 . "arc,*line,ELLIPSE")(-4 . "<not")(-4 . "&")(70 . 1)(-4 . "not>"))));过滤闭合多段线
   
5.   (or rrno1* (setq rrno1* 10.))
   
6.   (setq pt_cj(getpoint(strcat "\n输入点:")))
   
7.   (setq sslast (ssadd)
   
8.         sslast1 (ssadd)
   
9.    
   
10.   ss(try-ss2EnList ssd))
    
11.   (princ "\n")
    
12. 
    
13.   ;把所有图元的端点存入表
    
14.   (foreach x ss (setq lis(cons(vlax-curve-getStartPoint x)(cons(vlax-curve-getEndPoint x)lis))));多段线可能是重点
    
15.   (setq expert(getvar "expert" )n(/(length lis)100)i 0);n为端点个数除以100
    
16.   (setvar "expert" 1);禁止提示重生成
    
17.   (setvar "CMDECHO"0)
    
18. ;;;;====================================================================找出孤立点，pts，显示进度
    
19.   (command "UNDO" "BE")
    
20.   (vl-cmdf "qaflags" 1 ".explode" ssd "" "qaflags" 0);炸开，当qaflags=1时，选择集都被炸开，=0时，只能炸开第一个？？？？？
    
21. 
    
22.   (foreach pt lis
    
23.     (setq
    
24.       pp lis   ;端点点表
    
25.       n100(if (> n 0)(rem (setq i(1+ i)) n)1);           计算进度用参数
    
26.       pt1 (mapcar '+ pt '(0.001 0.001));放大显示
    
27.       pt2 (mapcar '- pt '(0.001 0.001))
    
28.       );放大显示
    
29.     (command "zoom" "w" "_non"pt1 "_non"pt2)
    
30.     (setq ssd (ssget "C" pt pt))
    
31.     (if (= 1 (sslength ssd))(setq pts(cons pt pts)));符合入点表，排除封闭的点，将孤立的点存入pts;;;===========
    
32.     (if (and(> n 2)(= n100 0))(princ(strcat "\r当前进度【"(rtos(* 100(/ i (length lis)1.0))2 0)"%】")));;;进度显示
    
33.     );foreach
    
34.   (command "UNDO""end" "U" "UNDO" "be")
    
35.   ;;;==================================================================找出孤立点，pts，显示进度
    
36. 
    
37. ;  (foreach x pts   
    
38. ;      (ssadd (entmakex (list '(0 . "LINE") (cons 10 x) (cons 11 pt_cj) (cons 62 1) )) sslast)
    
39. ;    );遍历孤立点画圆，并将圆存入sslast
    
40. 
    
41. 
    
42. 
    
43.   ;;===================================================================================连线悬挂点
    
44. (setq ss1 (sslength pts)
    
45.       i1 -1
    
46.       objl '()
    
47. )
    
48. 
    
49.   (repeat (- ss1 1)
    
50.     (setq aobj1 (nth(setq i1(1+ i1)) pts)
    
51.      mm(- ss1 i1 1)
    
52.      objl(cdr (member (nth i1 pts) pts))
    
53.      nb -1
    
54.     )
    
55.     (if(objl)
    
56.      (repeat mm
    
57.        (setq aobj2 (nth(setq nb(1+ nb)) obj1))
    
58.        (if (< (distance(aobj1 aobj2)) 10)
    
59.          (ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)
    
60.          );if <
    
61.        );repeat mm
    
62.      );if obj1
    
63.     );repeat ss1
    
64. ;;======================================================================================连线悬挂点
    
65.   (setvar "expert" expert)
    
66.   (command "UNDO""end")(setvar "CMDECHO"1)
    
67.   (sssetfirst nil sslast);;记住这两句即可(sssetfirst nil nil)取消所有亮显(sssetfirst nil ss)亮显ss
    
68.   (sssetfirst nil sslast1)
    
69.   (princ (strcat "\n找到悬空点"(itoa (length pts))"个。"))
    
70.   (prin1)
    
71.   )
    
72. ;;;;;======================================================自定义函数，选择集转为图元表
    
73. ;;参数：选择集；返回，图名表
    
74. (defun try-ss2EnList(ss / a en lst)
    
75.   (setq a -1)
    
76.   (if ss
    
77.     (while
    
78.       (setq en(ssname ss(setq a(1+ a))))
    
79.       (setq lst(cons en lst))
    
80.     )
    
81.   )
    
82.   (reverse lst)
    
83. 
    
84. )
    
85. (prin1)

;;悬空线检查<br /> (defun c:tt (/ expert i lis n n100 nn pp pt1 pt2 pts rr ss ssd sslast)<br />   (vl-Load-COM)<br />   (setq ssd(ssget'((0 . "arc,*line,ELLIPSE")(-4 . "<not")(-4 . "&")(70 . 1)(-4 . "not>"))));过滤闭合多段线<br />   (or rrno1* (setq rrno1* 10.))<br />   (setq pt_cj(getpoint(strcat "\n输入点:")))<br />   (setq sslast (ssadd)<br />         sslast1 (ssadd)<br />    <br />   ss(try-ss2EnList ssd))<br />   (princ "\n")<br /> <br />   ;把所有图元的端点存入表<br />   (foreach x ss (setq lis(cons(vlax-curve-getStartPoint x)(cons(vlax-curve-getEndPoint x)lis))));多段线可能是重点<br />   (setq expert(getvar "expert" )n(/(length lis)100)i 0);n为端点个数除以100<br />   (setvar "expert" 1);禁止提示重生成<br />   (setvar "CMDECHO"0)<br /> ;;;;====================================================================找出孤立点，pts，显示进度 <br />   (command "UNDO" "BE")<br />   (vl-cmdf "qaflags" 1 ".explode" ssd "" "qaflags" 0);炸开，当qaflags=1时，选择集都被炸开，=0时，只能炸开第一个？？？？？<br /> <br />   (foreach pt lis <br />     (setq <br />       pp lis   ;端点点表<br />       n100(if (> n 0)(rem (setq i(1+ i)) n)1);           计算进度用参数<br />       pt1 (mapcar '+ pt '(0.001 0.001));放大显示<br />       pt2 (mapcar '- pt '(0.001 0.001))<br />       );放大显示<br />     (command "zoom" "w" "_non"pt1 "_non"pt2)<br />     (setq ssd (ssget "C" pt pt))<br />     (if (= 1 (sslength ssd))(setq pts(cons pt pts)));符合入点表，排除封闭的点，将孤立的点存入pts;;;===========<br />     (if (and(> n 2)(= n100 0))(princ(strcat "\r当前进度【"(rtos(* 100(/ i (length lis)1.0))2 0)"%】")));;;进度显示<br />     );foreach<br />   (command "UNDO""end" "U" "UNDO" "be")<br />   ;;;==================================================================找出孤立点，pts，显示进度<br /> <br /> ;  (foreach x pts   <br /> ;      (ssadd (entmakex (list '(0 . "LINE") (cons 10 x) (cons 11 pt_cj) (cons 62 1) )) sslast)<br /> ;    );遍历孤立点画圆，并将圆存入sslast<br /> <br /> <br /> <br />   ;;===================================================================================连线悬挂点 <br /> (setq ss1 (sslength pts)<br />       i1 -1<br />       objl '()<br /> )<br /> <br />   (repeat (- ss1 1)<br />     (setq aobj1 (nth(setq i1(1+ i1)) pts)<br />      mm(- ss1 i1 1)<br />      objl(cdr (member (nth i1 pts) pts))<br />      nb -1<br />     )<br />     (if(objl)<br />      (repeat mm<br />        (setq aobj2 (nth(setq nb(1+ nb)) obj1))<br />        (if (< (distance(aobj1 aobj2)) 10)<br />          (ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)<br />          );if <<br />        );repeat mm<br />      );if obj1<br />     );repeat ss1<br /> ;;======================================================================================连线悬挂点 <br />   (setvar "expert" expert)<br />   (command "UNDO""end")(setvar "CMDECHO"1)<br />   (sssetfirst nil sslast);;记住这两句即可(sssetfirst nil nil)取消所有亮显(sssetfirst nil ss)亮显ss<br />   (sssetfirst nil sslast1)<br />   (princ (strcat "\n找到悬空点"(itoa (length pts))"个。"))<br />   (prin1)<br />   )<br /> ;;;;;======================================================自定义函数，选择集转为图元表<br /> ;;参数：选择集；返回，图名表<br /> (defun try-ss2EnList(ss / a en lst)<br />   (setq a -1)<br />   (if ss<br />     (while<br />       (setq en(ssname ss(setq a(1+ a))))<br />       (setq lst(cons en lst))<br />     )<br />   )<br />   (reverse lst)<br /> <br /> )<br /> (prin1)

xyp1964

1. ;; 悬空线检查
   
2. (defun c:tt (/ ptn pts)
   
3.   (if (setq ss (ssget '((0 . "arc,*line,ELLIPSE"))))
   
4.     (progn
   
5.       (setq ss1 (ssadd))
   
6.       (foreach x (xyp-Ss2List ss)
   
7.         (setq p1 (vlax-curve-getStartPoint x)
   
8.               p2 (vlax-curve-getEndPoint x)
   
9.         )
   
10.         (if (not (equal p1 p2))
    
11.           (setq ptn (append (list p1 p2) ptn))
    
12.         )
    
13.       )
    
14.       (foreach pt ptn
    
15.         (setq p1 (mapcar '+ pt '(1 1))
    
16.               p2 (mapcar '- pt '(1 1))
    
17.         )
    
18.         (command "zoom" "w" "_non" p1 "_non" p2)
    
19.         (if (= 1 (sslength (ssget "C" pt pt)))
    
20.           (setq pts (cons pt pts))
    
21.         )
    
22.       )
    
23.       (setq nn (length pts))
    
24.       (while (setq pt (car pts))
    
25.         (setq pts (cdr pts))
    
26.         (foreach p1 pts
    
27.           (if (< (distance pt p1) 10)
    
28.             (ssadd (entmakex
    
29.                      (list '(0 . "LINE") (cons 10 pt) (cons 11 p1) (cons 62 1))
    
30.                    )
    
31.                    ss1
    
32.             )
    
33.           )
    
34.         )
    
35.       )
    
36.       (command "zoom" "e")
    
37.       (if ss1(sssetfirst nil ss1))
    
38.       (princ (strcat "\n找到悬空点" (itoa nn) "个。"))
    
39.     )
    
40.   )
    
41.   (princ)
    
42. )

;; 悬空线检查<br /> (defun c:tt (/ ptn pts)<br />   (if (setq ss (ssget '((0 . "arc,*line,ELLIPSE"))))<br />     (progn<br />       (setq ss1 (ssadd))<br />       (foreach x (xyp-Ss2List ss)<br />         (setq p1 (vlax-curve-getStartPoint x)<br />               p2 (vlax-curve-getEndPoint x)<br />         )<br />         (if (not (equal p1 p2))<br />           (setq ptn (append (list p1 p2) ptn))<br />         )<br />       )<br />       (foreach pt ptn<br />         (setq p1 (mapcar '+ pt '(1 1))<br />               p2 (mapcar '- pt '(1 1))<br />         )<br />         (command "zoom" "w" "_non" p1 "_non" p2)<br />         (if (= 1 (sslength (ssget "C" pt pt)))<br />           (setq pts (cons pt pts))<br />         )<br />       )<br />       (setq nn (length pts))<br />       (while (setq pt (car pts))<br />         (setq pts (cdr pts))<br />         (foreach p1 pts<br />           (if (< (distance pt p1) 10)<br />             (ssadd (entmakex<br />                      (list '(0 . "LINE") (cons 10 pt) (cons 11 p1) (cons 62 1))<br />                    )<br />                    ss1<br />             )<br />           )<br />         )<br />       )<br />       (command "zoom" "e")<br />       (if ss1(sssetfirst nil ss1))<br />       (princ (strcat "\n找到悬空点" (itoa nn) "个。"))<br />     )<br />   )<br />   (princ)<br /> )

chenjieq1990

这段代码运行出错

1. (setq ss1 (sslength pts)
   
2.       i1 -1
   
3.       objl '()
   
4. )
   
5. 
   
6.   (repeat (- ss1 1)
   
7.     (setq aobj1 (nth(setq i1(1+ i1)) pts)
   
8.      mm(- ss1 i1 1)
   
9.      objl(cdr (member (nth i1 pts) pts))
   
10.      nb -1
    
11.     )
    
12.     (if(objl)
    
13.      (repeat mm
    
14.        (setq aobj2 (nth(setq nb(1+ nb)) obj1))
    
15.        (if (< (distance(aobj1 aobj2)) 10)
    
16.          (ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)
    
17.          );if <
    
18.        );repeat mm
    
19.      );if obj1
    
20.     );repeat ss1

(setq ss1 (sslength pts)<br />       i1 -1<br />       objl '()<br /> )<br /> <br />   (repeat (- ss1 1)<br />     (setq aobj1 (nth(setq i1(1+ i1)) pts)<br />      mm(- ss1 i1 1)<br />      objl(cdr (member (nth i1 pts) pts))<br />      nb -1<br />     )<br />     (if(objl)<br />      (repeat mm<br />        (setq aobj2 (nth(setq nb(1+ nb)) obj1))<br />        (if (< (distance(aobj1 aobj2)) 10)<br />          (ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)<br />          );if <<br />        );repeat mm<br />      );if obj1<br />     );repeat ss1

xyp1964

cawy113116 发表于 2021-2-28 18:16
这个函数（xyp-Ss2List）可以分享一下吗？

1. (defun xyp-Ss2List (ss / i s1 lst)
   
2.   (setq i -1)
   
3.   (while (setq s1 (ssname ss (setq i (1+ i))))
   
4.     (setq lst (cons s1 lst))
   
5.   )
   
6.   lst
   
7. )

(defun xyp-Ss2List (ss / i s1 lst)<br />   (setq i -1)<br />   (while (setq s1 (ssname ss (setq i (1+ i))))<br />     (setq lst (cons s1 lst))<br />   )<br />   lst<br /> )

chenjieq1990

xyp1964 发表于 2019-3-18 22:21

谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？

664571221

chenjieq1990 发表于 2019-3-19 08:09
谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？

怎么用不起来，请问怎么用啊

664571221

chenjieq1990 发表于 2019-3-19 08:09
谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？

怎么用不起来，请问怎么用啊

心中的梦想

收藏了，谢谢分享！！！！

cmcc15

您好，看了您的一些帖子，目前不封闭图形填充您做出插件了吗。可以用吗？

cawy113116

学习学习，最近一直想学习拓扑相关的

cawy113116

这个函数（xyp-Ss2List）可以分享一下吗？