本帖最后由 xiabin68 于 2013-1-26 00:23 编辑
搞定了，你试一试要的不，感谢Z版 的帮助才能写出代码
哈哈严哥出品绝对精品好用。。谢谢
那就不知道怎么会事了，
CASS几年间没有什么新功能，连帮助文件依旧那么粗糙。看到大家快吧它所有的功能重写完了，还都是源码公布。它坐在中国第一测绘软件的位置，再不出点新功能，开放一点帮助测绘人成长，它应该脸红。大侠们写出这等厉害的程序，会逼它上进的。
附上源码：;;;只对水平垂直双线有效
(defun c:tt(/ e1 e2 eclst1 fuzz ss n midp ss1 elst nearplst1 nearplst2)
(princ"\n选择删除范围")
(setq ss(ssget '((0 . "*line"))))
(setq e1(car(entsel"\n请选择要删除一类线的一个样本"))
eclst1(tt e1)
;fuzz 1500;;;可自己调
)
(setq fuzz(getdist"\n平行线间距"))
(command "zoom" "all")
(repeat (setq n(sslength ss))
(setq e2(ssname ss(setq n(1- n)))
eclst2(tt e2)
)
(if (equal eclst1 eclst2)
(progn
(setq midp(vlax-curve-getpointatparam e2 (/(-(vlax-curve-getparamatpoint e2 (vlax-curve-getendpoint e2))
(vlax-curve-getparamatpoint e2(vlax-curve-getstartpoint e2)))2)
)
)
(setq ss1(ssget "c" (list (-(car midp)fuzz)(-(cadr midp)fuzz))(list (+(car midp)fuzz)(+(cadr midp)fuzz))
(list '(-4 . "<and")'(0 . "*line")'(-4 . "<not")(cons 8 (car eclst1))'(-4 . "not>")'(-4 . "and>"))
))
(if ss1(setq elst(ss2lst ss1)))
(foreach x elst(setq nearplst1(cons (vlax-curve-getclosestpointto x midp)nearplst1)))
(setq nearplst1(vl-sort nearplst1 '(lambda(x y)(<(distance midpx)(distance midpy)))))
(setq memlst1( car nearplst1))
(setq memlst2(cadr nearplst1))
(if (=(abs(-(car memlst1)(car memlst2)))(+(distance memlst1 midp)(distance memlst2 midp)))
(vla-delete (vlax-ename->vla-object e2))
(progn
(if (=(abs(-(cadr memlst1)(cadr memlst2)))(+(distancememlst1 midp)(distancememlst2 midp)))
(vla-delete (vlax-ename->vla-object e2))
)
)
)
)
)
(setq nearplst1 nil)
)
(command "zoom" "p")
(princ)
)
(defun tt(e / s la col lst)
(setq s(entget e)
la(cdr(assoc 8 s))
col(cdr(assoc 62 s))
)
(setq lst(list la col))
(if (=(cadrlst)nil)
(setq lst(list (car lst) (cdr(assoc 62(entget(tblobjname "layer" la))))))
)
lst
)
(defun ss2lst (ss / n lst)
(repeat (setq n(sslength ss))
(setq lst (cons (ssname ss (setq n (1- n))) lst))
)
lst
)
(princ"\n记住我吧,命令tt")
用于梁删中心线，学习
用于梁删中心线，学习
在吗你的qq多少呀 ，我想加你，我看你在论坛发的和我的思路很像
yjr111 发表于 2013-1-25 17:07
起作用的在我手里啊
严老的你qq多少啊
用于梁删中心线，谢谢分享实用程序!!!!