纯LISP方法取得选择集中首尾相连的直线函数
前段时间编程遇到要将首尾相连的直线从选择集中挑选出来的功能。用region方法虽然能实现但是运行速度较慢，明经找的首尾相连函数又不怎么理想，只好自己动手了，没想到还挺复杂，循环套循环的绕的人头晕，现在好像调试通过了，纯lisp方法，运行速度还算比较快，发出来共享，给有需要的朋友。;;; [函数]取得选择集中首尾相连的直线
;;; 函数(lineclose ss p ),ss为直线选择集，
;;; p为真时，返回封闭直线端点列表。
;;; p为假时，返回封闭直线图元名列表。
(defun lineclose (ss p / ent i loop lsar lst lst0 lst00 lst001 lst01 lst1 lstn name pd pt3 pt4 ptn ptsar)
(setq lst '())
(repeat (setq i (sslength ss))
(setq name (ssname ss (setq i (1- i))) ent (entget name))
(if (= (cdr (assoc 0 ent)) "LINE")
(setq lst (cons (list name (cdr (assoc 10 ent)) (cdr (assoc 11 ent))) lst))))
(setq lst0 '()lst01 '())
(while (setq lsar (car lst))
(setq lst (cdr lst) lst1 lst ptsar (cadr lsar) ptn (last lsar))
(setq lst00 (list (last lsar)) lst001 (list (car lsar)) loop t)
(while loop
(setq pd nil)
(repeat (setq i (length lst1))
(setq lstn (nth (setq i (1- i)) lst1)pt3 (cadr lstn)pt4 (last lstn))
(if (equal pt3 ptn 0.00001)
(setq ptn pt4 lst00 (cons pt4 lst00) lst001 (cons (car lstn) lst001)
lst1 (vl-remove lstn lst1) pd t)
(if (equal pt4 ptn 0.00001)
(setq ptn pt3 lst00 (cons pt3 lst00) lst001 (cons (car lstn) lst001)
lst1 (vl-remove lstn lst1)pd t )))
(if (equal ptn ptsar 0.00001)
(setq loop nil lst0 (cons lst00 lst0)lst01 (cons lst001 lst01))))
(if (= pd nil)(setq loop nil))))
(if p lst0 lst01 )
)
;;; 示例1：首尾相连直线生成多段线
(defun c:test1 (/ lst lst1 pt ss x)
(setq ss (ssget (list '(0 . "line"))))
(setq lst (lineclose ss t))
(foreach x lst
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length x)) '(70 . 1))
(mapcar '(lambda (pt) (cons 10 pt)) x ))))
(princ)
)
;;; 示例2：首尾相连直线亮显
(defun c:test2 (/ lst name ss x)
(setq ss (ssget (list '(0 . "line"))))
(setq lst (lineclose ss nil))
(foreach x lst(foreach name x (redraw name 3)))
(princ)
)
本帖最后由 panliang9 于 2021-10-25 10:39 编辑
很早以前论坛里有一个贴子 “LISP 聚合 10000 个实体6秒”
是 “Urings” 写的，后来这个贴子找不到了。
他的程序就能以飞快的速度把炸碎的对象线连接起来。据“urings”在贴子里说这是他耗尽心力搞出的好东西。
我们获得了一些图纸，但图纸里块全碎了，利用他的程序很快的就把密密麻麻的对象理顺了。还是非常有用的。
本帖最后由 urings 于 2021-8-26 06:57 编辑
panliang9 发表于 2021-6-29 08:54
很早以前论坛里有一个贴子 “LISP 聚合 10000 个实体6秒”
是 “Urings” 写的，后来这个贴子是被他删 ...
当时是论坛出故障了，论坛的硬盘出故障了，数据丢失
我也搞了一个，利用过某点选选择循环得到相连线的点
(while (setq ent (car line_wall_list))
(setq pt0 (w:get-dxf ent 10))
(entdel ent)
(setq pts (list pt0))
(if (and pt0)
(vla-ZoomWindow (vlax-get-acad-object)
(vlax-3d-point (w:get-npt pt0 50000 50000 0))
(vlax-3d-point (w:get-npt pt0 -50000 -50000 0))
)
)
(while (and
(setq ss (ssget "C" pt0 pt0 (list (cons 0 "LINE")(cons 8 "砼墙"))))
(if (and ss)(setq lst (w:ss->lst ss)))
(setq ent1 (car lst))
(setq pt0_10 (w:get-dxf ent1 10))
(setq pt0_11 (w:get-dxf ent1 11))
(if(equal pt0 pt0_10 1e-6) (setq pt0 pt0_11)(setq pt0 pt0_10))
)
(setq pts (cons pt0 pts))
(setq line_wall_list (vl-remove ent1 line_wall_list))
(entdel ent1)
)
(setq wallent (w:mk-pline pts (list (cons 8 wall) (cons 62 256)(cons 70 1))))
(w:vl-hatch wallent "ANSI31" 100 256 wall_hacth 0)
(setq line_wall_list (cdr line_wall_list))
)
感谢无私分享 感谢大神的分享 对多段线无效吗？？？ 好像只对直线有用，希望能更新为对多段线也有用
感谢大神的分享 LeeMAC不是有一个链选吗Chain Selection，首尾相连的都可以选中 首尾相接其实比较容易，可能需要注意剔除下重叠的线。
其实做到这个程度，再把圆弧加上去就更完美了。
可以取代PE命令合成多段线。
然后再利用格林公式处理顺时针逆时针问题。
我有用VBA编写相关功能，PE实在是不好用。 感谢大神共享！