求个删除双线间的线插件麻烦高手帮帮忙谢谢

xiabin68

搞定了，你试一试要的不，感谢Z版 的帮助才能写出代码

flytoday

哈哈严哥出品绝对精品好用。。谢谢

xiabin68

那就不知道怎么会事了，

004

CASS几年间没有什么新功能，连帮助文件依旧那么粗糙。看到大家快吧它所有的功能重写完了，还都是源码公布。它坐在中国第一测绘软件的位置，再不出点新功能，开放一点帮助测绘人成长，它应该脸红。大侠们写出这等厉害的程序，会逼它上进的。

yjr111

附上源码：

2. ;;;只对水平垂直双线有效
   
3. (defun c:tt(/ e1 e2 eclst1 fuzz ss n midp ss1 elst nearplst1 nearplst2)
   
4.   (princ"\n选择删除范围")
   
5.   (setq ss(ssget '((0 . "*line"))))
   
6.   (setq e1(car(entsel"\n请选择要删除一类线的一个样本"))
   
7.         eclst1(tt e1)
   
8.         ;fuzz 1500;;;可自己调
   
9.         )
   
10.   (setq fuzz(getdist"\n平行线间距"))
    
11.   (command "zoom" "all")
    
12.   (repeat (setq n(sslength ss))
    
13.     (setq e2(ssname ss(setq n(1- n)))
    
14.           eclst2(tt e2)
    
15.           )
    
16.     (if (equal eclst1 eclst2)
    
17.       (progn
    
18.       (setq midp(vlax-curve-getpointatparam e2 (/(-(vlax-curve-getparamatpoint e2 (vlax-curve-getendpoint e2))
    
19.                                     (vlax-curve-getparamatpoint e2(vlax-curve-getstartpoint e2)))2)
    
20.                   )
    
21.         )
    
22.       (setq ss1(ssget "c" (list (-(car midp)fuzz)(-(cadr midp)fuzz))(list (+(car midp)fuzz)(+(cadr midp)fuzz))
    
23.              (list '(-4 . "<and")'(0 . "*line")'(-4 . "<not")(cons 8 (car eclst1))'(-4 . "not>")'(-4 . "and>"))
    
24.              ))
    
25.       (if ss1(setq elst(ss2lst ss1)))
    
26.       (foreach x elst(setq nearplst1(cons (vlax-curve-getclosestpointto x midp)nearplst1)))
    
27.       (setq nearplst1(vl-sort nearplst1 '(lambda(x y)(<(distance midp  x)(distance midp  y)))))
    
28.         (setq memlst1( car nearplst1))
    
29.         (setq memlst2(cadr nearplst1))
    
30.         (if (=(abs(-(car memlst1)(car memlst2)))(+(distance memlst1 midp)(distance memlst2 midp)))
    
31.             (vla-delete (vlax-ename->vla-object e2))
    
32.             (progn
    
33.               (if (=(abs(-(cadr memlst1)(cadr memlst2)))(+(distance  memlst1 midp)(distance  memlst2 midp)))
    
34.                (vla-delete (vlax-ename->vla-object e2))
    
35.               )
    
36.             )
    
37.         )
    
38.       )
    
39.       )
    
40.     (setq nearplst1 nil)
    
41.     )
    
42. (command "zoom" "p")
    
43. (princ)
    
44. )
    
45. (defun tt(e / s la col lst)
    
46.   (setq s(entget e)
    
47.         la(cdr(assoc 8 s))
    
48.         col(cdr(assoc 62 s))
    
49.         )
    
50.   (setq lst(list la col))
    
51.   (if (=(cadr  lst)nil)
    
52.     (setq lst(list (car lst) (cdr(assoc 62(entget(tblobjname "layer" la))))))
    
53.     )
    
54.   lst
    
55.   )
    
56. (defun ss2lst (ss / n lst)
    
57. (repeat (setq n(sslength ss))
    
58.    (setq lst (cons (ssname ss (setq n (1- n))) lst))
    
59.    )
    
60. lst
    
61. )
    
62. (princ"\n记住我吧,命令tt")
    

;;;只对水平垂直双线有效<br /> (defun c:tt(/ e1 e2 eclst1 fuzz ss n midp ss1 elst nearplst1 nearplst2)<br />   (princ"\n选择删除范围")<br />   (setq ss(ssget '((0 . "*line"))))<br />   (setq e1(car(entsel"\n请选择要删除一类线的一个样本"))<br />         eclst1(tt e1)<br />         ;fuzz 1500;;;可自己调<br />         )<br />   (setq fuzz(getdist"\n平行线间距"))<br />   (command "zoom" "all")<br />   (repeat (setq n(sslength ss))<br />     (setq e2(ssname ss(setq n(1- n)))<br />           eclst2(tt e2)<br />           )<br />     (if (equal eclst1 eclst2)<br />       (progn<br />       (setq midp(vlax-curve-getpointatparam e2 (/(-(vlax-curve-getparamatpoint e2 (vlax-curve-getendpoint e2))<br />                                     (vlax-curve-getparamatpoint e2(vlax-curve-getstartpoint e2)))2)<br />                   )<br />         )<br />       (setq ss1(ssget "c" (list (-(car midp)fuzz)(-(cadr midp)fuzz))(list (+(car midp)fuzz)(+(cadr midp)fuzz))<br />              (list '(-4 . "<and")'(0 . "*line")'(-4 . "<not")(cons 8 (car eclst1))'(-4 . "not>")'(-4 . "and>"))<br />              ))<br />       (if ss1(setq elst(ss2lst ss1)))<br />       (foreach x elst(setq nearplst1(cons (vlax-curve-getclosestpointto x midp)nearplst1)))<br />       (setq nearplst1(vl-sort nearplst1 '(lambda(x y)(<(distance midp  x)(distance midp  y)))))<br />         (setq memlst1( car nearplst1))<br />         (setq memlst2(cadr nearplst1))<br />         (if (=(abs(-(car memlst1)(car memlst2)))(+(distance memlst1 midp)(distance memlst2 midp)))<br />             (vla-delete (vlax-ename->vla-object e2))<br />             (progn<br />               (if (=(abs(-(cadr memlst1)(cadr memlst2)))(+(distance  memlst1 midp)(distance  memlst2 midp)))<br />                (vla-delete (vlax-ename->vla-object e2))<br />               )<br />             )<br />         )<br />       )<br />       )<br />     (setq nearplst1 nil)<br />     )<br /> (command "zoom" "p")<br /> (princ)<br /> )<br /> (defun tt(e / s la col lst)<br />   (setq s(entget e)<br />         la(cdr(assoc 8 s))<br />         col(cdr(assoc 62 s))<br />         )<br />   (setq lst(list la col))<br />   (if (=(cadr  lst)nil)<br />     (setq lst(list (car lst) (cdr(assoc 62(entget(tblobjname "layer" la))))))<br />     )<br />   lst<br />   )<br /> (defun ss2lst (ss / n lst)<br /> (repeat (setq n(sslength ss))<br />    (setq lst (cons (ssname ss (setq n (1- n))) lst))<br />    )<br /> lst<br /> )<br /> (princ"\n记住我吧,命令tt")<br />

朽木大师

用于梁删中心线，学习

enn09

用于梁删中心线，学习

664571221

在吗你的qq多少呀 ，我想加你，我看你在论坛发的和我的思路很像

664571221

yjr111 发表于 2013-1-25 17:07
起作用的在我手里啊

严老的你qq多少啊

yoyoho

用于梁删中心线，谢谢分享实用程序!!!!