删除超短,合并重叠,近邻平行的(lwpolyline,polyline)
本帖最后由 尘缘一生 于 2024-11-16 06:39 编辑有些问题，很重要，却没有完美解决办法，所以，对于真正设计者来说呢，总是个心病！甚至十年，几十年的都在记挂着，
总观众多的二开，甚至xyz ,画的图，也全是垃圾满篇，实体压落，这可能大家觉得没事，就该这样子，那是你对自己要求不高，或你根本就不知道，一套干净，标准的图纸是什么样的（实际上现实就不存在万分之一，哪之一就是我画的图），巧了的是我画图32年，对垃圾图纸是难以接收的，所以吗.....
不多说了，三领哪，对这个问题一直在留心，也一直在探讨，下面发布下最近研究点东西，友情提示：请不要说代码不能运行，哪当然不能，不全吗！
函数很明确，你难道不会自己替代？你的内裤呢？
;;列表中相距最远的两点表--(一级)------
;;(pmin pmax)
(defun sl:furthestapart (lst)
(car (sl-ptsmaxdist lst))
)
;点集中最远,最近两点表之表----(一级)-----
;返回:(最远两点 最近两点) ((p1 p2) (p3 p4))
(defun sl-ptsmaxdist (ptlst / pt n d plst maxd mind maxl minl)
(if (or (= (length ptlst) 1)
(and (= (length ptlst) 2) (= (distance (car ptlst) (cadr ptlst)) 0))
)
(setq maxl (list (car ptlst) (car ptlst)) minl maxl)
(progn
(setq minl (list (car ptlst) (cadr ptlst)) maxd 0 mind (apply 'distance minl))
(while (setq pt (car ptlst) ptlst (cdr ptlst))
(setq plst ptlst)
(while plst
(setq n (car plst) d (distance n pt))
(cond
((< maxd d) (setq maxd d maxl (list n pt)))
((> mind d) (setq mind d minl (list n pt)))
)
(setq plst (cdr plst))
)
)
)
)
(list maxl minl)
)
;;删除超短,合并重叠,近邻平行的多段线(lwpolyline,polyline)之整理------(一级)--------
;;Modfy by SLdesign 尘缘一生QQ:15290049
(defun unduppl1 (s / j ent ent1 lst lis1 lis2 lstx lsty lstx1 lsty1 nm len0 n ss ss1 nam enam1 enam2 spt1 ept1 spt2 ept2 d1 d2 d3 d4 m ly cl lt lw sw)
;;判断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 s))
;;删除长度小于 0.01的多段线
(repeat (setq n (sslength s))
(setq nam (ssname s (setq n (1- n))))
(if (<= (vlax-curve-getdistatparam nam (vlax-curve-getendparam nam)) 0.01)
(progn
(ssdel nam s)
(entdel nam)
(setq nm (1+ nm))
)
)
)
;删除完全重合------
;三领SLdesign 提示:此段程序可占时间
(setq ss1 (ssadd))
(setq n 0);初始化变量,设置i为1的原因是方便j取值
(repeat (1- (sslength s));外循环开始,循环次数为多段线个数减1
(setq ent (entget (ssname s 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 s) n);内循坏开始,循坏次数为多段线个数减去i
(setq nam (ssname s 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的表看是否一致,一致就删除
(progn (ssadd nam ss1) (setq nm (1+ nm)))
)
(setq j (1+ j))
)
)
(setq s (ssdiff s ss1) n -1)
(while (setq nam (ssname ss1 (setq n (1+ n))))
(entdel nam)
)
;;去除带凸度,不共线的----
(setq ss (ssadd) n -1)
(while (setq nam (ssname s (setq n (1+ n))))
(if (and (not (checkarc nam)) (sl:pts-onLine (get-pl-pt nam)))
(ssadd nam ss)
)
)
;合并连接重复,紧邻共线的 LWPOLYLINE,POLYLINE-----
(setq n -1)
(while (setq enam1 (ssname ss (setq n (1+ n))))
(setq lis1 (get-pl-pt 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 . "LWPOLYLINE,POLYLINE"))
)
)
(progn
(if (ssmemb enam1 s) (ssdel enam1 s)) ;;次选择集先删除主线
(if (> (sslength s) 0) ;确保ss存在实体
(progn
(setq ss1 (ssadd))
(repeat (setq j (sslength s))
(setq nam (ssname s (setq j (1- j))))
(if (ssmemb nam ss) ;如果在主选择集内处理,所以确ss1里,只有不带凸度,共线的直段线
(ssadd nam ss1)
)
) ;以上确保次集 ss1 正确
(setq m -1)
(if (> (sslength ss1) 0) ;如果ss1还存在实体
(while (setq enam2 (ssname ss1 (setq m (1+ m)))) ;while 2
(setq lis2 (get-pl-pt 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) sw nil
)
(cond
((and (slon_ent spt2 spt1 ept1) (slon_ent ept2 spt1 ept1));;次线落在主线上
(entdel enam2)
(setq nm (1+ nm))
)
((and (slon_ent spt1 spt2 ept2) (slon_ent ept1 spt2 ept2)) ;;主线落在次线上
(entdel enam1)
(setq enam1 enam2 spt1 spt2 ept1 ept2);次线转主线
(setq nm (1+ nm))
)
)
(if (sl:pts-onLine (list spt1 ept1 spt2 ept2)) ;两线共线
(cond
((slon_ent spt2 spt1 ept1) ;次线起点落在主线时
(setq sw t) ;也就是给个开关罢了
)
((slon_ent ept2 spt1 ept1) ;次线终点落在主线时
(setq sw t)
)
((< (min d1 d2 d3 d4) 0.03) ;离开的两线,但两线之间最短距离小于0.03!
(setq sw t)
)
)
;不共线的平行但离得很近的线也合并为一
(if (and ;(not (sl-Curveinters enam1 enam2 3)) ;无有交点,平行方法一
(equal (angle-sharp (angle spt1 ept1)) (angle-sharp (angle spt2 ept2)) 0.01);角度判断的平行方法二
(< (min d1 d2 d3 d4) 0.01) ;两线之间最短距离小于0.01!
)
(setq sw t)
)
)
(if sw
(progn
(setq lst (sl:furthestapart (list spt1 ept1 spt2 ept2)))
(setq spt1 (car lst) ept1 (last lst)) ;下次扩展延伸->go
(setq ly (dxf1 enam2 8) cl (sl-getcolor enam2) lw (linwind enam2) lt (sl-linetype enam2))
(entdel enam1)
(entdel enam2)
(slch:lwpolyline (list spt1 ept1) nil lw ly cl nil)
(sl:chnam-lintp (entlast) lt)
(setq enam1 (entlast))
(setq nm (1+ nm))
)
)
);end while 2
);if
)
)
)
) ;if
);end while
(prompt (strcat " 处理" (itoa len0) "个*POLYLINE消去" (itoa nm) "个"))
(princ)
)
;;测试---------
(defun c:tt (/ ss)
(if (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
(unduppl1 ss)
)
)
SLdesign 三领设计 V3.0永久测试下载地址：
通过百度网盘分享的文件：三领设计
链接：https://pan.baidu.com/s/1c-bZXuiCUXsCQyghmhaB3Q
提取码：7t06
垃圾问题之其他：
1：重叠的圆
2：重叠的文字
3：重叠的块
4：超短的线类
........
本坛广有程式存在-->可淘之
指望程序来处理各种画图不规范？有这精神还是看点书学习对各位更有帮助。 很好→很棒！很好~很棒！！很好……很棒！！！ 赞赞赞。越智能，要判定的情况就越多，代码也就越多，总有不在判定中的情况。。 很实用，高效 谢谢分享，谢谢分享 厉害，感谢高人的分享 overkill?000000000000000000000000
页:
[1]