adc 发表于 2014-1-13 13:56:16

交线处理



求一程序，四条平行线两两相交，框选之后间距小的线剪断，线的图层固定为a


cable2004 发表于 2014-1-13 13:56:17

本帖最后由 cable2004 于 2014-1-14 13:49 编辑

是你自己条件改变了。把条件说清楚，不要每天修改。

adc 发表于 2014-1-13 19:59:57

自己顶一下

cable2004 发表于 2014-1-14 01:33:50

(defun c:bb( / a b b1 b2 l lst1 lst2 p1 p2 ss1 ss2 x)
(setq l (ss->lst (ssget '((0 . "LINE"))))
        a (car l)
        l (cdr l)
        lst2 (list a))
(foreach x l (if (getinterpoint (vlax-ename->vla-object x)(vlax-ename->vla-object a))
                   (setq lst1 (cons x lst1))
                   (setq lst2 (cons x lst2))
))
(setq p1 (car (getinterpoint (vlax-ename->vla-object (car lst1))(vlax-ename->vla-object (car lst2))))
      p2 (car (getinterpoint (vlax-ename->vla-object (car lst1))(vlax-ename->vla-object (cadr lst2))))
      b1 (car (getinterpoint (vlax-ename->vla-object (cadr lst1))(vlax-ename->vla-object (car lst2))))
      b2 (car (getinterpoint (vlax-ename->vla-object (cadr lst1))(vlax-ename->vla-object (cadr lst2))))
)
(setq ss1 (ssadd))(ssadd (car lst1)ss1)(ssadd (cadr lst1)ss1)
(setq ss2 (ssadd))(ssadd (car lst2)ss2)(ssadd (cadr lst2)ss2)

(if (> (distance p1 p2)(distance p1 b1))
(progn
    (command"trim" ss2 "" (list (car lst1) (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)) "")
    (command"trim" ss2 "" (list (cadr lst1)(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) b1 b2)) "")
    )
    (progn
    (command"trim" ss1 "" (list (car lst2) (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 b1)) "")
    (command"trim" ss1 "" (list (cadr lst2)(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p2 b2)) "")
    )
)
)

(defun GetInterPoint (ent1 ent2 / intpoints points i) (setq intpoints (vla-intersectwith ent1 ent2 acextendnone))
(setq intpoints (vlax-variant-value intpoints))
(setq i 0)
(if (> (vlax-safearray-get-u-bound intpoints 1) 0)
(repeat (/ (+ 1
(- (vlax-safearray-get-u-bound intpoints 1)
(vlax-safearray-get-l-bound intpoints 1)
)
)
3
)
(setq points (append points (list (list
(vlax-safearray-get-element intpoints i)
(vlax-safearray-get-element intpoints (+ i 1))
(vlax-safearray-get-element intpoints (+ i 2))
)))
)
(setq i (+ 3 i))
)
)
points
)

(defun ss->lst ( ss / i l )
    (if ss
      (repeat (setq i (sslength ss))
            (setq l (cons (ssname ss (setq i (1- i))) l))
      )))

adc 发表于 2014-1-14 12:22:24

本帖最后由 adc 于 2014-1-14 12:57 编辑



cable2004 发表于 2014-1-14 01:33 http://bbs.mjtd.com/static/image/common/back.gif
(defun c:bb( / a b b1 b2 l lst1 lst2 p1 p2 ss1 ss2 x)
(setq l (ss->lst (ssget '((0 . "LINE"))))
...

多谢，不过程序执行时如果选了其他图层的线就不能正常执行，还有能不能支持自定义ucs，测试文件见附件

Andyhon 发表于 2014-1-14 17:36:27

有不少的提问类属于投石问路...

自己的实务应用有几许的状况得全交待在附件中以免衍生困扰
(以通过该调试文件为准)

程序有个从简原则,以满足现况需求为准
往后碰上新状况再补

adc 发表于 2014-1-14 20:03:06

本帖最后由 adc 于 2014-1-14 20:26 编辑

cable2004 发表于 2014-1-13 13:56 http://bbs.mjtd.com/static/image/common/back.gif
是你自己条件改变了。把条件说清楚，不要每天修改。

sorry，我没有描述清楚，多谢了，不过前面已经描述了线的图层固定为a，是希望只对图层a的对象进行操作，现在的程序不论什么图层都会剪切，测试文件里的对象图层也是a

adc 发表于 2014-1-14 20:36:12

Andyhon 发表于 2014-1-14 17:36 static/image/common/back.gif
有不少的提问类属于投石问路...

自己的实务应用有几许的状况得全交待在附件中以免衍生困扰


测试文件没有改变，只是没有描述清楚，已经给了明经币了
页: [1]
查看完整版本: 交线处理