删除重复实体（SLdesign V3.0集成）
本帖最后由 尘缘一生 于 2025-4-24 10:53 编辑关于删除重复实体，本坛不少代码，哪么，在使用过程中，不断完善代码，
由于是集成的，难以全部源码展示，运行需挂SLdesign；但原理是最主要的思想，展示以便讨论，
;Modify By SLdesign V3.0 (三领设计 V3.0)
;By 尘缘一生QQ:152900492025,10,24
;;图元合并删除,合并----【开始】------c:duprem
(defun c:tt (/ ss)
(if (setq ss (ssget '((0 . "LINE,*P*LINE,TEXT,MTEXT,TCH_TEXT,TCH_MTEXT,CIRCLE,INSERT"))))
(ssduppe ss)
)
)
;;(删除选择集中重叠的线,多段线,圆,块,文字)----(一级)----
(defun ssduppe (ss / name lis lw ly cl lt tp sline slinex scircle sinsert stxt n ss1 ss2 ss3)
(_undo1)
(setq sline (ssadd) slinex (ssadd) scircle (ssadd) sinsert (ssadd) stxt (ssadd) ss1 (ssadd) ss2 (ssadd) ss3 (ssadd) n -1)
(while (setq name (ssname ss (setq n (1+ n))))
(setq tp (dxf1 name 0))
(cond
((= tp "LINE")
(ssadd name sline)
)
((= tp "CIRCLE")
(ssadd name scircle)
)
((= tp "INSERT")
(ssadd name sinsert)
)
((member tp '("TEXT" "MTEXT" "TCH_TEXT" "TCH_MTEXT"))
(ssadd name stxt)
)
((member tp '("LWPOLYLINE" "POLYLINE"))
(if (> (vlax-curve-getdistatparam name (vlax-curve-getendparam name)) 0.01)
(progn
(setq lis (get-pl-pt name) ly (dxf1 name 8) cl (sl-getcolor name) lw (linwind name) lt (sl-linetype name))
(if (sl:pts-onLine lis) ;共线
(progn
(setq lis (sl:furthestapart lis))
(if (> lw 0)
(slch:lwpolyline (list (car lis) (cadr lis)) nil lw ly cl nil)
(fy_lineformat (makeline (car lis) (cadr lis)) ly lt nil cl)
)
(sl:chnam-lintp (entlast) lt)
(ssadd (entlast) slinex)
(ssadd name ss1);->去删除
)
(if (= tp "LWPOLYLINE")
(ssadd name ss2)
(progn
(if (sl:isClosed name) ;闭合
(slch:lwpolyline lis t lw ly cl 1.0)
(slch:lwpolyline lis nil lw ly cl 1.0)
)
(sl:chnam-lintp (entlast) lt)
(ssadd (entlast) ss2)
(ssadd name ss1);->去删除
)
)
)
)
(ssadd name ss1);->去删除
)
)
)
)
;先处理直线集
(setq n -1)
(if (> (sslength sline) 0)
(while (setq name (ssname sline (setq n (1+ n))))
(if (<= (vlax-curve-getdistatparam name (vlax-curve-getendparam name)) 0.01)
(ssadd name ss1) ;->去删除
(ssadd name ss3) ;->去处理完全重合
)
)
)
;删除ss1
(setq n -1)
(if (> (sslength ss1) 0)
(while (setq name (ssname ss1 (setq n (1+ n)))) (entdel name))
)
(if (> (sslength ss3) 1) (setq ss3 (undupll ss3))) ;去除完全重合的LINE
;处理后ss3加入slinex ->
(setq n -1)
(if (> (sslength ss3) 0)
(while (setq name (ssname ss3 (setq n (1+ n)))) (ssadd name slinex))
)
;分类处理
(if (> (sslength scircle) 1) (undup-cir scircle)) ;圆
(if (> (sslength stxt) 1) (deladtxt stxt)) ;文字
(if (> (sslength sinsert) 1) (congfukuai sinsert)) ;块
(if (> (sslength slinex) 0) (undupplx slinex)) ;线类
(if (> (sslength ss2) 1) (duplwpoly ss2)) ;删除完全重复的LWPOLYLINE
(_undo2)
)
;完全重线line消除----(一级)--------
;返回处理后剩余选择集
(defun undupll (s / lst n pt10 pt11 lst_new enam a nm)
(setq lst '() n 0 nm 0)
(repeat (sslength s)
(setq enam (ssname s n) pt10 (dxf1 enam 10) pt11 (dxf1 enam 11))
(setq lst (cons (list enam pt10 pt11) lst))
(setq n (1+ n))
)
(while lst
(setq a(car lst) lst (cdr lst))
(setq lst_new '())
(foreach n lst
(if(or (equal (cdr a) (cdr n) 0.01) (equal (cdr a) (reverse (cdr n)) 0.01))
(progn
(ssdel (car n) s)
(entdel (car n)) ;_删除实体
(setq nm (1+ nm))
)
(setq lst_new (cons n lst_new))
)
)
(setq lst lst_new)
)
(if (> nm 0)
(prompt
(strcat
(slmsg "删除" "" "Delete")
(itoa nm)
(slmsg "个完全重合LINE" "ЧLINE" "Num Completely overlapping LINE")
)
)
)
s
)
;删除完全重合的LWPOLYLINE----(一级)--------
(defun duplwpoly (ss / s n j m lstx lsty lstx1 lsty1 nam ent ent1 lst lis1)
(setq s (ssadd))
(setq n 0);初始化变量,设置i为1的原因是方便j取值
(repeat (1- (sslength ss));外循环开始,循环次数为多段线个数减1
(setq ent (entget (ssname ss n)));得到DXF
(setq lst (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent)));提取点表
(setq lstx (mapcar 'car (vl-sort lst '(lambda (a b) (< (car a) (car b))))));按照X坐标从小到大排序并提取X坐标组成表
(setq lsty (mapcar 'cadr (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b))))));按照Y坐标从小到大排序并提取Y坐标组成表
(setq n (1+ n))
(setq j n);j的值为n
(repeat (- (sslength ss) n);内循坏开始,循坏次数为多段线个数减去i
(setq nam (ssname ss j))
(setq ent1 (entget nam)) ;得到DXF
(setq lis1 (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent1))) ;提取点表
(setq lstx1 (mapcar 'car (vl-sort lis1 '(lambda (a b) (< (car a) (car b)))))) ;同样按照X坐标从小到大排序并提取X坐标组成表
(setq lsty1 (mapcar 'cadr (vl-sort lis1 '(lambda (a b) (< (cadr a) (cadr b)))))) ;同样按照Y坐标从小到大排序并提取Y坐标组成表
(if (and (equal lstx lstx1 1e-5) (equal lsty lsty1 1e-5)) ;对比两个X和两个Y的表看是否一致,一致就删除
(ssadd nam s)
)
(setq j (1+ j))
)
)
(if (> (setq m (sslength s)) 0)
(progn
(setq n -1)
(while (setq nam (ssname s (setq n (1+ n)))) (entdel nam))
(prompt
(strcat
(slmsg "删除" "" "Delete")
(itoa m)
(slmsg "个完全重合LWPOLYLINE" "ЧLWPOLYLINE" "Num Completely overlapping LWPOLYLINE")
)
)
)
)
)
;;合并重叠,近邻共线或平行的(line,lwpolyline,polyline)-----(一级)--------
;;ss 直段共线的 *LINE 选择集
(defun undupplx (ss / lisn1 lisn2 lst lis1 lis2 nm len0 n s ss1 nam enam1 enam2 spt1 ept1 spt2 ept2 d1 d2 d3 d4 ly cl lt lt1 lt2 lw a a1 a2)
;;判断点a是否在 a1至a2两点连线上
(defun slon_ent (a a1 a2)
(equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.0001)
)
;;--------------------
(setq nm 0 len0 (sslength ss) lisn1 (ss-enlst ss))
(while (setq enam1 (car lisn1))
(setq lis1 (getpt (ssadd enam1)))
(setq lis1 (sl:furthestapart lis1) spt1 (car lis1) ept1 (last lis1))
(if (setq s (ssget "CP"
(list
(polar spt1 (angle ept1 spt1) 4.5)
(polar ept1 (- (angle spt1 ept1) pi4) 4.5)
(polar ept1 (+ (angle spt1 ept1) pi4) 4.5)
)
'((0 . "LINE,LWPOLYLINE,POLYLINE"))
)
)
(progn
(if (ssmemb enam1 s) (ssdel enam1 s)) ;;次选择集先删除主线enam1
(if (> (sslength s) 0) ;确保s存在实体
(progn
(setq ss1 (ssadd))
(repeat (setq n (sslength s))
(setq nam (ssname s (setq n (1- n))))
(if (ssmemb nam ss)
(ssadd nam ss1)
)
) ;以上确保次集ss1属于ss集内的,确保共线集
(if (> (sslength ss1) 0) ;如果ss1还存在实体
(progn
(setq lisn2 (ss-enlst ss1))
(while (setq enam2 (car lisn2)) ;while 2 ,注ename2 也是lisn1的实体且是共线的
(setq lis2 (getpt (ssadd enam2)))
(setq lis2 (sl:furthestapart lis2) spt2 (car lis2) ept2 (last lis2) d1 (distance spt1 spt2)
d2 (distance spt1 ept2) d3 (distance ept1 spt2) d4 (distance ept1 ept2)
)
(if (or
(and (slon_ent spt2 spt1 ept1) (slon_ent ept2 spt1 ept1)) ;;次线落在主线上
(and (slon_ent spt1 spt2 ept2) (slon_ent ept1 spt2 ept2)) ;;主线落在次线上
(and
(sl:pts-onLine (list spt1 ept1 spt2 ept2)) ;两线共线
(or
(slon_ent spt2 spt1 ept1) ;次线起点落在主线时
(slon_ent ept2 spt1 ept1) ;次线终点落在主线时
(< (min d1 d2 d3 d4) 0.03) ;离开的两线,但两线之间最短距离小于0.03!
)
)
(and ;平行但离得很近的线也合并为一
(equal (angle-sharp (angle spt1 ept1)) (angle-sharp (angle spt2 ept2)) 0.01);角度判断的平行方法二
(< (min d1 d2 d3 d4) 0.01) ;两线之间最短距离小于0.01!
)
)
(progn
(setq lst (sl:furthestapart (list spt1 ept1 spt2 ept2)))
(setq spt1 (car lst) ept1 (last lst)) ;下次扩展延伸->go
(setq ly (dxf1 enam1 8) cl (sl-getcolor enam1) lw (linwind enam1) lt1 (sl-linetype enam1) lt2 (sl-linetype enam2))
(if (= lt1 "CONTINUOUS")
(if (= lt2 "CONTINUOUS")
(setq lt lt1)
(setq lt lt2)
)
(setq lt lt1)
)
(setq lisn1 (remove_ite_list lisn1 enam1))
(setq lisn1 (remove_ite_list lisn1 enam2))
(setq lisn2 (remove_ite_list lisn2 enam2))
(entdel enam1)
(entdel enam2)
(setq nm (1+ nm))
(if (> lw 0)
(slch:lwpolyline (list spt1 ept1) nil lw ly cl nil)
(fy_lineformat (makeline spt1 ept1) ly lt nil cl)
)
(sl:chnam-lintp (entlast) lt)
(setq enam1 (entlast))
(setq lisn1 (append lisn1 (list enam1))) ;合并后实体加入 lisn1 继续处理
)
(progn
(setq lisn2 (cdr lisn2))
(setq lisn1 (remove_ite_list lisn1 enam2))
)
)
);end while 2
)
);if (> (sslength ss1) 0)ss1还存在实体
)
)
)
) ;if "CP"
(setq lisn1 (cdr lisn1))
);end while
(prompt
(strcat
(slmsg " 处理" " 矪瞶" " Delete Merge")
(itoa len0)
(slmsg "个 <*LINE>" " <*LINE>" "Num <*LINE>")
(slmsg "消去" "" "Delete")
(itoa nm)
(slmsg "个" "" "Num")
)
)
(princ)
)
感谢大佬分享 多谢尘缘总分享 过得有点快 尘佬穿越回来的? 能单独出一个脱离外挂插件的纯lisp吗 用来用去，还是用overkill，不折腾了 mj0000 发表于 2025-4-26 16:10
用来用去，还是用overkill，不折腾了
overkill有时候删不干净{:1_1:}
页:
[1]