悬挂点 并智能连线
本帖最后由 chenjieq1990 于 2019-3-18 14:32 编辑对论坛上的悬挂点程序进行了一定的修改，思路是这样的，源程序是在悬挂点处增加一个圆圈，本代码通过比较悬挂点之间的距离差，将距离差小于一定值的两个悬挂点通过直线连接，但是运行时候一直出错，看谁能帮忙看下。
悬挂点参考 http://bbs.mjtd.com/forum.php?mo ... D5%CF%DF&page=1
;;悬空线检查
(defun c:tt (/ expert i lis n n100 nn pp pt1 pt2 pts rr ss ssd sslast)
(vl-Load-COM)
(setq ssd(ssget'((0 . "arc,*line,ELLIPSE")(-4 . "<not")(-4 . "&")(70 . 1)(-4 . "not>"))));过滤闭合多段线
(or rrno1* (setq rrno1* 10.))
(setq pt_cj(getpoint(strcat "\n输入点:")))
(setq sslast (ssadd)
sslast1 (ssadd)
ss(try-ss2EnList ssd))
(princ "\n")
;把所有图元的端点存入表
(foreach x ss (setq lis(cons(vlax-curve-getStartPoint x)(cons(vlax-curve-getEndPoint x)lis))));多段线可能是重点
(setq expert(getvar "expert" )n(/(length lis)100)i 0);n为端点个数除以100
(setvar "expert" 1);禁止提示重生成
(setvar "CMDECHO"0)
;;;;====================================================================找出孤立点，pts，显示进度
(command "UNDO" "BE")
(vl-cmdf "qaflags" 1 ".explode" ssd "" "qaflags" 0);炸开，当qaflags=1时，选择集都被炸开，=0时，只能炸开第一个？？？？？
(foreach pt lis
(setq
pp lis ;端点点表
n100(if (> n 0)(rem (setq i(1+ i)) n)1); 计算进度用参数
pt1 (mapcar '+ pt '(0.001 0.001));放大显示
pt2 (mapcar '- pt '(0.001 0.001))
);放大显示
(command "zoom" "w" "_non"pt1 "_non"pt2)
(setq ssd (ssget "C" pt pt))
(if (= 1 (sslength ssd))(setq pts(cons pt pts)));符合入点表，排除封闭的点，将孤立的点存入pts;;;===========
(if (and(> n 2)(= n100 0))(princ(strcat "\r当前进度【"(rtos(* 100(/ i (length lis)1.0))2 0)"%】")));;;进度显示
);foreach
(command "UNDO""end" "U" "UNDO" "be")
;;;==================================================================找出孤立点，pts，显示进度
;(foreach x pts
; (ssadd (entmakex (list '(0 . "LINE") (cons 10 x) (cons 11 pt_cj) (cons 62 1) )) sslast)
; );遍历孤立点画圆，并将圆存入sslast
;;===================================================================================连线悬挂点
(setq ss1 (sslength pts)
i1 -1
objl '()
)
(repeat (- ss1 1)
(setq aobj1 (nth(setq i1(1+ i1)) pts)
mm(- ss1 i1 1)
objl(cdr (member (nth i1 pts) pts))
nb -1
)
(if(objl)
(repeat mm
(setq aobj2 (nth(setq nb(1+ nb)) obj1))
(if (< (distance(aobj1 aobj2)) 10)
(ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)
);if <
);repeat mm
);if obj1
);repeat ss1
;;======================================================================================连线悬挂点
(setvar "expert" expert)
(command "UNDO""end")(setvar "CMDECHO"1)
(sssetfirst nil sslast);;记住这两句即可(sssetfirst nil nil)取消所有亮显(sssetfirst nil ss)亮显ss
(sssetfirst nil sslast1)
(princ (strcat "\n找到悬空点"(itoa (length pts))"个。"))
(prin1)
)
;;;;;======================================================自定义函数，选择集转为图元表
;;参数：选择集；返回，图名表
(defun try-ss2EnList(ss / a en lst)
(setq a -1)
(if ss
(while
(setq en(ssname ss(setq a(1+ a))))
(setq lst(cons en lst))
)
)
(reverse lst)
)
(prin1)
;; 悬空线检查
(defun c:tt (/ ptn pts)
(if (setq ss (ssget '((0 . "arc,*line,ELLIPSE"))))
(progn
(setq ss1 (ssadd))
(foreach x (xyp-Ss2List ss)
(setq p1 (vlax-curve-getStartPoint x)
p2 (vlax-curve-getEndPoint x)
)
(if (not (equal p1 p2))
(setq ptn (append (list p1 p2) ptn))
)
)
(foreach pt ptn
(setq p1 (mapcar '+ pt '(1 1))
p2 (mapcar '- pt '(1 1))
)
(command "zoom" "w" "_non" p1 "_non" p2)
(if (= 1 (sslength (ssget "C" pt pt)))
(setq pts (cons pt pts))
)
)
(setq nn (length pts))
(while (setq pt (car pts))
(setq pts (cdr pts))
(foreach p1 pts
(if (< (distance pt p1) 10)
(ssadd (entmakex
(list '(0 . "LINE") (cons 10 pt) (cons 11 p1) (cons 62 1))
)
ss1
)
)
)
)
(command "zoom" "e")
(if ss1(sssetfirst nil ss1))
(princ (strcat "\n找到悬空点" (itoa nn) "个。"))
)
)
(princ)
) 这段代码运行出错
(setq ss1 (sslength pts)
i1 -1
objl '()
)
(repeat (- ss1 1)
(setq aobj1 (nth(setq i1(1+ i1)) pts)
mm(- ss1 i1 1)
objl(cdr (member (nth i1 pts) pts))
nb -1
)
(if(objl)
(repeat mm
(setq aobj2 (nth(setq nb(1+ nb)) obj1))
(if (< (distance(aobj1 aobj2)) 10)
(ssadd (entmakex (list '(0 . "LINE") (cons 10 (nth i1 pts)) (cons 11 (nth nb obj1)) (cons 62 1) )) sslast1)
);if <
);repeat mm
);if obj1
);repeat ss1 cawy113116 发表于 2021-2-28 18:16
这个函数（xyp-Ss2List）可以分享一下吗？
(defun xyp-Ss2List (ss / i s1 lst)
(setq i -1)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq lst (cons s1 lst))
)
lst
) xyp1964 发表于 2019-3-18 22:21
谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？ chenjieq1990 发表于 2019-3-19 08:09
谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？
怎么用不起来，请问怎么用啊 chenjieq1990 发表于 2019-3-19 08:09
谢谢，优化了一下，程序简练了很多，也快了很多，谢谢，请教下，foreach是比while快的吗？
怎么用不起来，请问怎么用啊 收藏了，谢谢分享！！！！ 您好，看了您的一些帖子，目前不封闭图形填充您做出插件了吗。可以用吗？ 学习学习，最近一直想学习拓扑相关的 这个函数（xyp-Ss2List）可以分享一下吗？
页:
[1]
2