删除重复对象

ORCHI

支持，正需要这个。

tzan8752

果断顶起果断顶起果断顶起果断顶起

bzhjl

支持一个

flyfox1047

再发删除重复线

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))

xiaoyuzj-503

感谢分享。

树櫴希德

overkill好像清不完

qiushizhda

支持         

enn09

支持楼主!

零幽默

支持楼主!

crab3

支持楼主!路过