[原创]更新：消除合并重复线条程序！修正了一个错误！
本帖最后由 作者 于 2003-10-10 15:23:10 编辑;;修正了一个错误。
;;这个更快，可以连接线条。
;;消除合并重复线条
(defun c:yad_undup(/ dxf tang chg_ent on_ent undup os 2pi sline sarc scircle n ss ent pmt)
(defun dxf(ent i)
(cdr (assoc i (entget ent)))
)
(defun tang(ang sty)
(rem (+ 2pi ang) sty)
)
(defun chg_ent(ent i pt / en)
(setq en (entget ent) en (subst (cons i pt) (assoc i en) en))
(entmod en)
)
(defun on_ent(a a1 a2 sty)
(if (= sty "直线")
(equal (+ (distance a1 a) (distance a a2)) (distance a1 a2) 0.01)
(if (> a2 a1) (>= a2 a a1) (or (<= a a2) (>= a a1)))
)
)
(defun undup(s sty / nm m ss ent1 spt1 ept1 cpt1 r1 ent2 spt2 ept2 cpt2 r2)
(setq n -1 nm 0)
(if (= sty "圆")
(repeat (sslength s)
(setq ent1 (ssname s (setq n (1+ n))))
(if (entget ent1)
(progn
(setq cpt1 (dxf ent1 10) r1 (dxf ent1 40))
(if (setq ss (ssget "x" (list (cons 0 "circle") (cons 10 cpt1) (cons 40 r1))))
(progn
(ssdel ent1 ss)
(setq m -1)
(repeat (sslength ss)
(setq ent (ssname ss (setq m (1+ m))))
(if (not (ssmemb ent s))
(progn
(ssdel ent ss)
(setq m (1- m))
)
)
)
(command "_.erase" ss "")
(setq nm (+ nm (sslength ss)))
)
)
)
)
)
(repeat (sslength s)
(setq ent1 (ssname s (setq n (1+ n))))
(if (entget ent1)
(progn
(if (= sty "直线")
(setq spt1 (dxf ent1 10) ept1 (dxf ent1 11))
(setq spt1 (tang (dxf ent1 50) 2pi)
ept1 (tang (dxf ent1 51) 2pi)
cpt1 (dxf ent1 10)
r1 (dxf ent1 40)
)
)
(if (setq ss (if (= sty "直线")
(ssget "cp" (list (polar spt1 (angle ept1 spt1) 0.1)
(polar ept1 (- (angle spt1 ept1) (/ pi 4)) 0.15)
(polar ept1 (+ (angle spt1 ept1) (/ pi 4)) 0.15)
) '((0 . "line"))
)
(ssget "x" (list (cons 0 "arc") (cons 10 cpt1) (cons 40 r1)))
)
)
(progn
(ssdel ent1 ss)
(setq m -1)
(repeat (sslength ss)
(setq ent (ssname ss (setq m (1+ m))))
(if (not (ssmemb ent s))
(progn
(ssdel ent ss)
(setq m (1- m))
)
)
)
(setq m -1)
(repeat (sslength ss)
(setq ent2 (ssname ss (setq m (1+ m))))
(if (= sty "直线")
(setq spt2 (dxf ent2 10)
ept2 (dxf ent2 11)
)
(setq spt2 (tang (dxf ent2 50) 2pi)
ept2 (tang (dxf ent2 51) 2pi)
cpt2 (dxf ent2 10)
r2 (dxf ent2 40)
)
)
(cond
((and (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty))
(entdel ent2)
)
((and (on_ent spt1 spt2 ept2 sty) (on_ent ept1 spt2 ept2 sty))
(entdel ent1)
(setq ent1 ent2 spt1 spt2 ept1 ept2)
(if (= sty "圆弧")
(setq cpt1 cpt2 r1 r2)
)
)
((and (if (= sty "直线")
(equal (tang (angle spt1 ept1) pi) (tang (angle spt2 ept2) pi) 0.001)
T
)
(or (on_ent spt2 spt1 ept1 sty) (on_ent ept2 spt1 ept1 sty))
)
(entdel ent2)
(if (= sty "直线")
(progn
(if (on_ent spt2 spt1 ept1 sty)
(setq spt2 ept2)
)
(if (> (distance spt1 spt2) (distance ept1 spt2))
(progn (chg_ent ent1 11 spt2) (setq ept1 spt2))
(progn (chg_ent ent1 10 spt2) (setq spt1 spt2))
)
)
(if (on_ent spt2 spt1 ept1 sty)
(progn (chg_ent ent1 51 ept2) (setq ept1 ept2))
(progn (chg_ent ent1 50 spt2) (setq spt1 spt2))
)
)
)
(T (setq nm (1- nm)))
)
(setq nm (1+ nm))
)
)
)
)
)
)
)
(prompt (strcat "选到" (itoa (sslength s)) "个" sty "消去" (itoa nm) "个！"))
)
(command "_.undo" "_be")
(command "_.ucs" "")
(setq os (getvar "osmode")
2pi (* 2 pi)
sline (ssadd)
sarc (ssadd)
scircle (ssadd)
n -1
)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(prompt "\n请选择直线、圆弧或圆：")
(if (setq ss (ssget '((0 . "line,arc,circle"))))
(progn
(prompt "\n正在消除合并重复线条，请稍候...")
(prompt "\n")
(repeat (sslength ss)
(setq ent (ssname ss (setq n (1+ n))))
(cond
((= (dxf ent 0) "LINE") (ssadd ent sline))
((= (dxf ent 0) "ARC") (ssadd ent sarc))
((= (dxf ent 0) "CIRCLE") (ssadd ent scircle))
)
)
)
)
(if (> (sslength sline) 1) (progn (undup sline "直线") (setq pmt T)))
(if (> (sslength sarc) 1) (progn (undup sarc "圆弧") (setq pmt T)))
(if (> (sslength scircle) 1) (progn (undup scircle "圆") (setq pmt T)))
(if (and ss (not pmt)) (prompt "\n没有重复实体！"))
(setvar "osmode" os)
(command "_.undo" "_e")
(princ)
)
(prompt "\n***消除合并重复线条yad_undup***YAD建筑")
(princ) 可以不要那么绝对吗其实很多重复线实际并不重复，如果能输入一个值就更完美了，比如两条直线 并没有重复相隔0.1mm那这个就删除不了 可以输入一个值 距离1mm那么如果距离小于1mm就当重复线删除 ，如果两条线不一样长保留长的 CAD自带的OVERKILL命令删除重复能功强大，可以试试。 最快的就是用ARX了 本帖最后由 作者 于 2003-9-25 11:09:30 编辑
即然有刪重複線的,那有自動串接的嗎???
再請教大蝦們一個問題
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=9348
龍大俠有給過一個列子,可是vlisp我看不懂,手上又沒這方面的書 谢谢lyy，正是我想要的，
麻烦您大侠帮人帮到底，在您的程序上加多些注释，简单讲一下您的思路。万分感谢！！！ 有没有框选一些线段就可以让它们自动连接成pl线的lsp程序，其中包括不相接的圆弧和直线段和相交的直线段让它们自动延伸或剪切合并成一条pl线。 CAD的增强工具EXPRESS有个命令Pljoin有这个功能。 厉害 lyy发表于2003-9-24 23:10:00static/image/common/back.gif更新：消除合并重复线条程序！修正了一个错误！
;;修正了一个错误。
;;这个更快，可以连接线条。
;;消除合并重复线条
(defun c:yad_undup(/ dxf tang chg_ent on_ent undup os 2pi slin
测了没有，10000条直线要多少时间? 你有这么多重复的线？
看来你画图是很不规范了 一般都是整个图选中，消.
测一下是有必要的，不然自己都不会去用它.
我看10000条20秒要吧.而express只一秒不到.