删除重复对象

flyfox1047

老外网上下的，带对话框，感觉还没ET的Overkill好用，源文件拿出来，想研究的拿去吧

再多上几个吧


再发删除重复线

1. (defun unique ( linlst )
   
2.   (if (car linlst) (cons (car linlst) (unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
   
3. )
   
4. 
   
5. (defun _vl-remove ( el lst fuzz )
   
6.   (vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
   
7. )
   
8. 
   
9. (defun eraseduplin ( ss / i lin p1 p2 lay col62 col420 linlst linlsta linlstn )
   
10.   (setq i -1)
    
11.   (while (setq lin (ssname ss (setq i (1+ i))))
    
12.     (setq p1 (cdr (assoc 10 (entget lin)))
    
13.           p2 (cdr (assoc 11 (entget lin)))
    
14.           lay (cdr (assoc 8 (entget lin)))
    
15.           col62 (cdr (if (assoc 62 (entget lin)) (assoc 62 (entget lin)) nil))
    
16.           col420 (cdr (if (assoc 420 (entget lin)) (assoc 420 (entget lin)) nil))
    
17.     )
    
18.     (setq linlsta (cons (list p1 p2 lay col62 col420) linlsta))
    
19.     (setq linlst (cons (list p1 p2) linlst))
    
20.     (entdel lin)
    
21.   )
    
22.   (setq linlstn (unique linlst))
    
23.   (foreach lin linlsta
    
24.     (if (vl-some '(lambda ( x ) (and (equal (car x) (car lin) 1e-8) (equal (cadr x) (cadr lin) 1e-8))) linlstn)
    
25.       (setq linlstn (subst lin (list (car lin) (cadr lin)) linlstn))
    
26.     )
    
27.   )
    
28.   (foreach lin linlstn
    
29.     (entmake (vl-remove nil (list '(0 . "LINE") (cons 8 (caddr lin)) (if (cadddr lin) (cons 62 (cadddr lin))) (if (caddr (cddr lin)) (cons 420 (caddr (cddr lin)))) (cons 10 (car lin)) (cons 11 (cadr lin)))))
    
30.   )
    
31. )
    
32. 
    
33. (defun c:eraseduplines-0lines ( / ss s i k lin )
    
34.   (setq ss (ssget "_:L" '((0 . "LINE"))))
    
35.   (setq s (ssadd))
    
36.   (setq i -1)
    
37.   (setq k 0)
    
38.   (while (setq lin (ssname ss (setq i (1+ i))))
    
39.     (if (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) 1e-4) (progn (setq k (1+ k)) (entdel lin)) (ssadd lin s))
    
40.   )
    
41.   (prompt "\nTotal : ")(princ (eraseduplin s))(prompt " duplicate-lines erased")
    
42.   (prompt "\nTotal : ")(princ k)(prompt " zero-lines erased")
    
43.   (princ)
    
44. )
    
45. 
    
46. (defun c:ed0l nil (c:eraseduplines-0lines))

(defun unique ( linlst )<br />   (if (car linlst) (cons (car linlst) (unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))<br /> )<br /> <br /> (defun _vl-remove ( el lst fuzz )<br />   (vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)<br /> )<br /> <br /> (defun eraseduplin ( ss / i lin p1 p2 lay col62 col420 linlst linlsta linlstn )<br />   (setq i -1)<br />   (while (setq lin (ssname ss (setq i (1+ i))))<br />     (setq p1 (cdr (assoc 10 (entget lin)))<br />           p2 (cdr (assoc 11 (entget lin)))<br />           lay (cdr (assoc 8 (entget lin)))<br />           col62 (cdr (if (assoc 62 (entget lin)) (assoc 62 (entget lin)) nil))<br />           col420 (cdr (if (assoc 420 (entget lin)) (assoc 420 (entget lin)) nil))<br />     )<br />     (setq linlsta (cons (list p1 p2 lay col62 col420) linlsta))<br />     (setq linlst (cons (list p1 p2) linlst))<br />     (entdel lin)<br />   )<br />   (setq linlstn (unique linlst))<br />   (foreach lin linlsta<br />     (if (vl-some '(lambda ( x ) (and (equal (car x) (car lin) 1e-8) (equal (cadr x) (cadr lin) 1e-8))) linlstn)<br />       (setq linlstn (subst lin (list (car lin) (cadr lin)) linlstn))<br />     )<br />   )<br />   (foreach lin linlstn<br />     (entmake (vl-remove nil (list '(0 . "LINE") (cons 8 (caddr lin)) (if (cadddr lin) (cons 62 (cadddr lin))) (if (caddr (cddr lin)) (cons 420 (caddr (cddr lin)))) (cons 10 (car lin)) (cons 11 (cadr lin)))))<br />   )<br /> )<br /> <br /> (defun c:eraseduplines-0lines ( / ss s i k lin )<br />   (setq ss (ssget "_:L" '((0 . "LINE"))))<br />   (setq s (ssadd))<br />   (setq i -1)<br />   (setq k 0)<br />   (while (setq lin (ssname ss (setq i (1+ i))))<br />     (if (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) 1e-4) (progn (setq k (1+ k)) (entdel lin)) (ssadd lin s))<br />   )<br />   (prompt "\nTotal : ")(princ (eraseduplin s))(prompt " duplicate-lines erased")<br />   (prompt "\nTotal : ")(princ k)(prompt " zero-lines erased")<br />   (princ)<br /> )<br /> <br /> (defun c:ed0l nil (c:eraseduplines-0lines))

jkop

支持楼主！老外的程序也能试试参考，都多多益善。

479274135

看帖回帖好习惯  楼主辛苦

菜冬瓜

楼主真是无私奉献啊！谢谢了！

sicky111

这么多人下载，怎么都没见一个人支持楼主。

peraperson

我来支持楼主

ysq101

少人回复我相信是应该要验证码吧。。。。。

flyfox1047

ysq101 发表于 2013-12-12 14:05
少人回复我相信是应该要验证码吧。。。。。

LSP都是源码，又没编译，怎会要验证码？

edata

flyfox1047 发表于 2013-12-12 14:10
LSP都是源码，又没编译，怎会要验证码？

四楼只的是 回帖需要验证码。。现在貌似没有验证码了。

xujinhua

楼主顶你...这么多好东东

haoryh

路过也顶一下！

mycad

谢谢！！！！！！！！！

混沌初开

支持楼主!