支持，正需要这个。
果断顶起果断顶起果断顶起果断顶起
支持一个
再发删除重复线
(defun unique ( linlst )
(if (car linlst) (cons (car linlst) (unique (_vl-remove (car linlst) (_vl-remove (list (cadar linlst) (caar linlst)) (cdr linlst) 1e-6) 1e-6))))
)
(defun _vl-remove ( el lst fuzz )
(vl-remove-if '(lambda ( x ) (and (equal (car x) (car el) fuzz) (equal (cadr x) (cadr el) fuzz))) lst)
)
(defun eraseduplin ( ss / i lin p1 p2 lay col62 col420 linlst linlsta linlstn )
(setq i -1)
(while (setq lin (ssname ss (setq i (1+ i))))
(setq p1 (cdr (assoc 10 (entget lin)))
p2 (cdr (assoc 11 (entget lin)))
lay (cdr (assoc 8 (entget lin)))
col62 (cdr (if (assoc 62 (entget lin)) (assoc 62 (entget lin)) nil))
col420 (cdr (if (assoc 420 (entget lin)) (assoc 420 (entget lin)) nil))
)
(setq linlsta (cons (list p1 p2 lay col62 col420) linlsta))
(setq linlst (cons (list p1 p2) linlst))
(entdel lin)
)
(setq linlstn (unique linlst))
(foreach lin linlsta
(if (vl-some '(lambda ( x ) (and (equal (car x) (car lin) 1e-8) (equal (cadr x) (cadr lin) 1e-8))) linlstn)
(setq linlstn (subst lin (list (car lin) (cadr lin)) linlstn))
)
)
(foreach lin linlstn
(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)))))
)
)
(defun c:eraseduplines-0lines ( / ss s i k lin )
(setq ss (ssget "_:L" '((0 . "LINE"))))
(setq s (ssadd))
(setq i -1)
(setq k 0)
(while (setq lin (ssname ss (setq i (1+ i))))
(if (equal (cdr (assoc 10 (entget lin))) (cdr (assoc 11 (entget lin))) 1e-4) (progn (setq k (1+ k)) (entdel lin)) (ssadd lin s))
)
(prompt "\nTotal : ")(princ (eraseduplin s))(prompt " duplicate-lines erased")
(prompt "\nTotal : ")(princ k)(prompt " zero-lines erased")
(princ)
)
(defun c:ed0l nil (c:eraseduplines-0lines))
感谢分享。
overkill好像清不完
支持
支持楼主!
支持楼主!
支持楼主!路过