删除超短,合并重叠,近邻平行的(lwpolyline,polyline)

尘缘一生

有些问题，很重要，却没有完美解决办法，所以，对于真正设计者来说呢，总是个心病！甚至十年，几十年的都在记挂着，
总观众多的二开，甚至xyz ,画的图，也全是垃圾满篇，实体压落，这可能大家觉得没事，就该这样子，那是你对自己要求不高，或你根本就不知道，一套干净，标准的图纸是什么样的（实际上现实就不存在万分之一，哪之一就是我画的图），巧了的是我画图32年，对垃圾图纸是难以接收的，所以吗.....
不多说了，三领哪，对这个问题一直在留心，也一直在探讨，下面发布下最近研究点东西，友情提示：请不要说代码不能运行，哪当然不能，不全吗！
函数很明确，你难道不会自己替代？你的内裤呢？

2. ;;列表中相距最远的两点表--(一级)------
   
3. ;;(pmin pmax)
   
4. (defun sl:furthestapart (lst)
   
5.   (car (sl-ptsmaxdist lst))
   
6. )
   
7. ;点集中最远,最近两点表之表----(一级)-----
   
8. ;返回:(最远两点 最近两点) ((p1 p2) (p3 p4))
   
9. (defun sl-ptsmaxdist (ptlst / pt n d plst maxd mind maxl minl)
   
10.   (if (or (= (length ptlst) 1)
    
11.         (and (= (length ptlst) 2) (= (distance (car ptlst) (cadr ptlst)) 0))
    
12.       )
    
13.     (setq maxl (list (car ptlst) (car ptlst)) minl maxl)
    
14.     (progn
    
15.       (setq minl (list (car ptlst) (cadr ptlst)) maxd 0 mind (apply 'distance minl))
    
16.       (while (setq pt (car ptlst) ptlst (cdr ptlst))
    
17.         (setq plst ptlst)
    
18.         (while plst
    
19.           (setq n (car plst) d (distance n pt))
    
20.           (cond
    
21.             ((< maxd d) (setq maxd d maxl (list n pt)))
    
22.             ((> mind d) (setq mind d minl (list n pt)))
    
23.           )
    
24.           (setq plst (cdr plst))
    
25.         )
    
26.       )
    
27.     )
    
28.   )
    
29.   (list maxl minl)
    
30. )
    
31. 
    
32. ;;删除超短,合并重叠,近邻平行的多段线(lwpolyline,polyline)之整理------(一级)--------
    
33. ;;Modfy by SLdesign 尘缘一生  QQ:15290049
    
34. (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)
    
35.   ;;判断a是否在 a1至a2两点连线上
    
36.   (defun slon_ent (a a1 a2)
    
37.     (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.0001)
    
38.   )
    
39.   ;;--------------------
    
40.   (setq nm 0 len0 (sslength s))
    
41.   ;;删除长度小于 0.01的多段线
    
42.   (repeat (setq n (sslength s))
    
43.     (setq nam (ssname s (setq n (1- n))))
    
44.     (if (<= (vlax-curve-getdistatparam nam (vlax-curve-getendparam nam)) 0.01)
    
45.       (progn
    
46.         (ssdel nam s)
    
47.         (entdel nam)
    
48.         (setq nm (1+ nm))
    
49.       )
    
50.     )
    
51.   )
    
52.   ;删除完全重合------
    
53.   ;三领SLdesign 提示:此段程序可占时间
    
54.   (setq ss1 (ssadd))
    
55.   (setq n 0)  ;初始化变量,设置i为1的原因是方便j取值
    
56.   (repeat (1- (sslength s))  ;外循环开始,循环次数为多段线个数减1
    
57.     (setq ent (entget (ssname s n)))  ;得到DXF
    
58.     (setq lst (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent)))  ;提取点表
    
59.     (setq lstx (mapcar 'car (vl-sort lst '(lambda (a b) (< (car a) (car b))))))  ;按照X坐标从小到大排序并提取X坐标组成表
    
60.     (setq lsty (mapcar 'cadr (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b))))))  ;按照Y坐标从小到大排序并提取Y坐标组成表
    
61.     (setq n (1+ n))
    
62.     (setq j n)     ;j的值为n
    
63.     (repeat (- (sslength s) n)  ;内循坏开始,循坏次数为多段线个数减去i
    
64.       (setq nam (ssname s j))
    
65.       (setq ent1 (entget nam))   ;得到DXF
    
66.       (setq lis1 (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent1))) ;提取点表
    
67.       (setq lstx1 (mapcar 'car (vl-sort lis1 '(lambda (a b) (< (car a) (car b)))))) ;同样按照X坐标从小到大排序并提取X坐标组成表
    
68.       (setq lsty1 (mapcar 'cadr (vl-sort lis1 '(lambda (a b) (< (cadr a) (cadr b)))))) ;同样按照Y坐标从小到大排序并提取Y坐标组成表
    
69.       (if (and (equal lstx lstx1 1e-5) (equal lsty lsty1 1e-5)) ;对比两个X和两个Y的表看是否一致,一致就删除
    
70.         (progn (ssadd nam ss1) (setq nm (1+ nm)))
    
71.       )
    
72.       (setq j (1+ j))
    
73.     )
    
74.   )
    
75.   (setq s (ssdiff s ss1) n -1)
    
76.   (while (setq nam (ssname ss1 (setq n (1+ n))))
    
77.     (entdel nam)
    
78.   )
    
79.   ;;去除带凸度,不共线的----
    
80.   (setq ss (ssadd) n -1)
    
81.   (while (setq nam (ssname s (setq n (1+ n))))
    
82.     (if (and (not (checkarc nam)) (sl:pts-onLine (get-pl-pt nam)))
    
83.       (ssadd nam ss)
    
84.     )
    
85.   )
    
86.   ;合并连接重复,紧邻共线的 LWPOLYLINE,POLYLINE-----
    
87.   (setq n -1)
    
88.   (while (setq enam1 (ssname ss (setq n (1+ n))))
    
89.     (setq lis1 (get-pl-pt enam1))
    
90.     (setq lis1 (sl:furthestapart lis1) spt1 (car lis1) ept1 (last lis1))
    
91.     (if (setq s (ssget "CP"
    
92.                   (list
    
93.                     (polar spt1 (angle ept1 spt1) 4.5)
    
94.                     (polar ept1 (- (angle spt1 ept1) pi4) 4.5)
    
95.                     (polar ept1 (+ (angle spt1 ept1) pi4) 4.5)
    
96.                   )
    
97.                   '((0 . "LWPOLYLINE,POLYLINE"))
    
98.                 )
    
99.         )
    
100.       (progn
     
101.         (if (ssmemb enam1 s) (ssdel enam1 s)) ;;次选择集先删除主线
     
102.         (if (> (sslength s) 0) ;确保ss存在实体
     
103.           (progn
     
104.             (setq ss1 (ssadd))
     
105.             (repeat (setq j (sslength s))
     
106.               (setq nam (ssname s (setq j (1- j))))
     
107.               (if (ssmemb nam ss) ;如果在主选择集内处理,所以确ss1里,只有不带凸度,共线的直段线
     
108.                 (ssadd nam ss1)
     
109.               )
     
110.             ) ;以上确保次集 ss1 正确
     
111.             (setq m -1)
     
112.             (if (> (sslength ss1) 0) ;如果ss1还存在实体
     
113.               (while (setq enam2 (ssname ss1 (setq m (1+ m)))) ;while 2
     
114.                 (setq lis2 (get-pl-pt enam2))
     
115.                 (setq lis2 (sl:furthestapart lis2) spt2 (car lis2) ept2 (last lis2) d1 (distance spt1 spt2)
     
116.                   d2 (distance spt1 ept2) d3 (distance ept1 spt2) d4 (distance ept1 ept2) sw nil
     
117.                 )
     
118.                 (cond
     
119.                   ((and (slon_ent spt2 spt1 ept1) (slon_ent ept2 spt1 ept1))  ;;次线落在主线上
     
120.                     (entdel enam2)
     
121.                     (setq nm (1+ nm))
     
122.                   )
     
123.                   ((and (slon_ent spt1 spt2 ept2) (slon_ent ept1 spt2 ept2)) ;;主线落在次线上
     
124.                     (entdel enam1)
     
125.                     (setq enam1 enam2 spt1 spt2 ept1 ept2);次线转主线
     
126.                     (setq nm (1+ nm))
     
127.                   )
     
128.                 )
     
129.                 (if (sl:pts-onLine (list spt1 ept1 spt2 ept2)) ;两线共线
     
130.                   (cond
     
131.                     ((slon_ent spt2 spt1 ept1) ;次线起点落在主线时
     
132.                       (setq sw t) ;也就是给个开关罢了
     
133.                     )
     
134.                     ((slon_ent ept2 spt1 ept1) ;次线终点落在主线时
     
135.                       (setq sw t)
     
136.                     )
     
137.                     ((< (min d1 d2 d3 d4) 0.03) ;离开的两线,但两线之间最短距离小于0.03!
     
138.                       (setq sw t)
     
139.                     )
     
140.                   )
     
141.                   ;不共线的平行但离得很近的线也合并为一
     
142.                   (if (and    ;(not (sl-Curveinters enam1 enam2 3)) ;无有交点,平行方法一
     
143.                         (equal (angle-sharp (angle spt1 ept1)) (angle-sharp (angle spt2 ept2)) 0.01);角度判断的平行方法二
     
144.                         (< (min d1 d2 d3 d4) 0.01) ;两线之间最短距离小于0.01!
     
145.                       )
     
146.                     (setq sw t)
     
147.                   )
     
148.                 )
     
149.                 (if sw
     
150.                   (progn
     
151.                     (setq lst (sl:furthestapart (list spt1 ept1 spt2 ept2)))
     
152.                     (setq spt1 (car lst) ept1 (last lst)) ;下次扩展延伸->go
     
153.                     (setq ly (dxf1 enam2 8) cl (sl-getcolor enam2) lw (linwind enam2) lt (sl-linetype enam2))
     
154.                     (entdel enam1)
     
155.                     (entdel enam2)
     
156.                     (slch:lwpolyline (list spt1 ept1) nil lw ly cl nil)
     
157.                     (sl:chnam-lintp (entlast) lt)
     
158.                     (setq enam1 (entlast))
     
159.                     (setq nm (1+ nm))
     
160.                   )
     
161.                 )
     
162.               );end while 2
     
163.             );if
     
164.           )
     
165.         )
     
166.       )
     
167.     ) ;if
     
168.   );end while
     
169.   (prompt (strcat " 处理" (itoa len0) "个*POLYLINE  消去" (itoa nm) "个"))
     
170.   (princ)
     
171. )
     
172. ;;测试---------
     
173. (defun c:tt (/ ss)
     
174.   (if (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
     
175.     (unduppl1 ss)
     
176.   )
     
177. )

;;列表中相距最远的两点表--(一级)------<br /> ;;(pmin pmax)<br /> (defun sl:furthestapart (lst)<br />   (car (sl-ptsmaxdist lst))<br /> )<br /> ;点集中最远,最近两点表之表----(一级)-----<br /> ;返回:(最远两点 最近两点) ((p1 p2) (p3 p4))<br /> (defun sl-ptsmaxdist (ptlst / pt n d plst maxd mind maxl minl)<br />   (if (or (= (length ptlst) 1)<br />         (and (= (length ptlst) 2) (= (distance (car ptlst) (cadr ptlst)) 0))<br />       )<br />     (setq maxl (list (car ptlst) (car ptlst)) minl maxl)<br />     (progn<br />       (setq minl (list (car ptlst) (cadr ptlst)) maxd 0 mind (apply 'distance minl))<br />       (while (setq pt (car ptlst) ptlst (cdr ptlst))<br />         (setq plst ptlst)<br />         (while plst<br />           (setq n (car plst) d (distance n pt))<br />           (cond <br />             ((< maxd d) (setq maxd d maxl (list n pt)))<br />             ((> mind d) (setq mind d minl (list n pt)))<br />           )<br />           (setq plst (cdr plst))<br />         )<br />       )<br />     )<br />   )<br />   (list maxl minl)<br /> )<br /> <br /> ;;删除超短,合并重叠,近邻平行的多段线(lwpolyline,polyline)之整理------(一级)--------<br /> ;;Modfy by SLdesign 尘缘一生  QQ:15290049<br /> (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)<br />   ;;判断a是否在 a1至a2两点连线上<br />   (defun slon_ent (a a1 a2)<br />     (equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.0001)<br />   )<br />   ;;--------------------<br />   (setq nm 0 len0 (sslength s))<br />   ;;删除长度小于 0.01的多段线<br />   (repeat (setq n (sslength s))<br />     (setq nam (ssname s (setq n (1- n))))<br />     (if (<= (vlax-curve-getdistatparam nam (vlax-curve-getendparam nam)) 0.01)<br />       (progn <br />         (ssdel nam s)<br />         (entdel nam)<br />         (setq nm (1+ nm))<br />       )<br />     )<br />   )<br />   ;删除完全重合------<br />   ;三领SLdesign 提示:此段程序可占时间<br />   (setq ss1 (ssadd))<br />   (setq n 0)  ;初始化变量,设置i为1的原因是方便j取值<br />   (repeat (1- (sslength s))  ;外循环开始,循环次数为多段线个数减1<br />     (setq ent (entget (ssname s n)))  ;得到DXF<br />     (setq lst (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent)))  ;提取点表<br />     (setq lstx (mapcar 'car (vl-sort lst '(lambda (a b) (< (car a) (car b))))))  ;按照X坐标从小到大排序并提取X坐标组成表<br />     (setq lsty (mapcar 'cadr (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b))))))  ;按照Y坐标从小到大排序并提取Y坐标组成表<br />     (setq n (1+ n))<br />     (setq j n)     ;j的值为n<br />     (repeat (- (sslength s) n)  ;内循坏开始,循坏次数为多段线个数减去i<br />       (setq nam (ssname s j))<br />       (setq ent1 (entget nam))   ;得到DXF<br />       (setq lis1 (mapcar 'cdr (vl-remove-if '(lambda (x) (/= (car x) 10)) ent1))) ;提取点表<br />       (setq lstx1 (mapcar 'car (vl-sort lis1 '(lambda (a b) (< (car a) (car b)))))) ;同样按照X坐标从小到大排序并提取X坐标组成表<br />       (setq lsty1 (mapcar 'cadr (vl-sort lis1 '(lambda (a b) (< (cadr a) (cadr b)))))) ;同样按照Y坐标从小到大排序并提取Y坐标组成表<br />       (if (and (equal lstx lstx1 1e-5) (equal lsty lsty1 1e-5)) ;对比两个X和两个Y的表看是否一致,一致就删除<br />         (progn (ssadd nam ss1) (setq nm (1+ nm)))<br />       )<br />       (setq j (1+ j))<br />     )<br />   )<br />   (setq s (ssdiff s ss1) n -1)<br />   (while (setq nam (ssname ss1 (setq n (1+ n))))<br />     (entdel nam)<br />   )<br />   ;;去除带凸度,不共线的----<br />   (setq ss (ssadd) n -1)<br />   (while (setq nam (ssname s (setq n (1+ n))))<br />     (if (and (not (checkarc nam)) (sl:pts-onLine (get-pl-pt nam)))<br />       (ssadd nam ss)<br />     )<br />   )<br />   ;合并连接重复,紧邻共线的 LWPOLYLINE,POLYLINE-----<br />   (setq n -1)<br />   (while (setq enam1 (ssname ss (setq n (1+ n))))<br />     (setq lis1 (get-pl-pt enam1))<br />     (setq lis1 (sl:furthestapart lis1) spt1 (car lis1) ept1 (last lis1))<br />     (if (setq s (ssget "CP"<br />                   (list<br />                     (polar spt1 (angle ept1 spt1) 4.5)<br />                     (polar ept1 (- (angle spt1 ept1) pi4) 4.5)<br />                     (polar ept1 (+ (angle spt1 ept1) pi4) 4.5)<br />                   )<br />                   '((0 . "LWPOLYLINE,POLYLINE"))<br />                 )<br />         )<br />       (progn<br />         (if (ssmemb enam1 s) (ssdel enam1 s)) ;;次选择集先删除主线<br />         (if (> (sslength s) 0) ;确保ss存在实体<br />           (progn<br />             (setq ss1 (ssadd))<br />             (repeat (setq j (sslength s))<br />               (setq nam (ssname s (setq j (1- j))))<br />               (if (ssmemb nam ss) ;如果在主选择集内处理,所以确ss1里,只有不带凸度,共线的直段线<br />                 (ssadd nam ss1)<br />               )<br />             ) ;以上确保次集 ss1 正确<br />             (setq m -1)<br />             (if (> (sslength ss1) 0) ;如果ss1还存在实体<br />               (while (setq enam2 (ssname ss1 (setq m (1+ m)))) ;while 2<br />                 (setq lis2 (get-pl-pt enam2))<br />                 (setq lis2 (sl:furthestapart lis2) spt2 (car lis2) ept2 (last lis2) d1 (distance spt1 spt2)<br />                   d2 (distance spt1 ept2) d3 (distance ept1 spt2) d4 (distance ept1 ept2) sw nil<br />                 )<br />                 (cond <br />                   ((and (slon_ent spt2 spt1 ept1) (slon_ent ept2 spt1 ept1))  ;;次线落在主线上<br />                     (entdel enam2) <br />                     (setq nm (1+ nm))<br />                   )<br />                   ((and (slon_ent spt1 spt2 ept2) (slon_ent ept1 spt2 ept2)) ;;主线落在次线上<br />                     (entdel enam1)<br />                     (setq enam1 enam2 spt1 spt2 ept1 ept2);次线转主线<br />                     (setq nm (1+ nm))<br />                   )<br />                 )<br />                 (if (sl:pts-onLine (list spt1 ept1 spt2 ept2)) ;两线共线<br />                   (cond <br />                     ((slon_ent spt2 spt1 ept1) ;次线起点落在主线时<br />                       (setq sw t) ;也就是给个开关罢了<br />                     )<br />                     ((slon_ent ept2 spt1 ept1) ;次线终点落在主线时<br />                       (setq sw t)<br />                     )<br />                     ((< (min d1 d2 d3 d4) 0.03) ;离开的两线,但两线之间最短距离小于0.03!<br />                       (setq sw t)<br />                     )<br />                   )<br />                   ;不共线的平行但离得很近的线也合并为一<br />                   (if (and    ;(not (sl-Curveinters enam1 enam2 3)) ;无有交点,平行方法一<br />                         (equal (angle-sharp (angle spt1 ept1)) (angle-sharp (angle spt2 ept2)) 0.01);角度判断的平行方法二<br />                         (< (min d1 d2 d3 d4) 0.01) ;两线之间最短距离小于0.01!<br />                       )<br />                     (setq sw t)<br />                   )<br />                 )<br />                 (if sw <br />                   (progn <br />                     (setq lst (sl:furthestapart (list spt1 ept1 spt2 ept2)))<br />                     (setq spt1 (car lst) ept1 (last lst)) ;下次扩展延伸->go<br />                     (setq ly (dxf1 enam2 8) cl (sl-getcolor enam2) lw (linwind enam2) lt (sl-linetype enam2))<br />                     (entdel enam1) <br />                     (entdel enam2)<br />                     (slch:lwpolyline (list spt1 ept1) nil lw ly cl nil)<br />                     (sl:chnam-lintp (entlast) lt)<br />                     (setq enam1 (entlast))<br />                     (setq nm (1+ nm))<br />                   )<br />                 )<br />               );end while 2<br />             );if<br />           )<br />         )<br />       )<br />     ) ;if<br />   );end while<br />   (prompt (strcat " 处理" (itoa len0) "个*POLYLINE  消去" (itoa nm) "个"))<br />   (princ)<br /> )<br /> ;;测试---------<br /> (defun c:tt (/ ss)<br />   (if (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))<br />     (unduppl1 ss)<br />   )<br /> )

SLdesign 三领设计 V3.0  永久测试下载地址：

通过百度网盘分享的文件：三领设计
链接：https://pan.baidu.com/s/1c-bZXuiCUXsCQyghmhaB3Q
提取码：7t06




垃圾问题之其他：
1：重叠的圆
2：重叠的文字
3：重叠的块
4：超短的线类
........
本坛广有程式存在-->可淘之

e2002

指望程序来处理各种画图不规范？有这精神还是看点书学习对各位更有帮助。

寒潮大冬瓜

很好→很棒！很好~很棒！！很好……很棒！！！

chslwj521

赞赞赞。越智能，要判定的情况就越多，代码也就越多，总有不在判定中的情况。。

qd001

很实用，高效

gf123

谢谢分享，谢谢分享