一个有意思的程序，试试吧：xt = 修剪曲线距最近交点点取边

狂刀lxx

2. 
   
3. ;| xt = 修剪曲线距最近交点点取边 --ok--by lxx.2007.2
   
4. 功能: 以曲线与其它曲线最进交点为判断点,修剪曲线点取处的一边.
   
5. |;
   
6. (defun c:xt (/ A BOX D11 D12 D21 D22 E EE EE2 LL P RR SS nm nm2)
   
7.   (vl-load-com)
   
8.   (while
   
9.     (and
   
10.       (setq a (entsel))
    
11.       (setq e  (car a)
    
12.      nm (vla-get-objectname (vlax-ename->vla-object e))
    
13.       )
    
14.       (setq p (vlax-curve-getclosestpointto e (cadr a)))
    
15.     )
    
16.      (setq ee (entlast))
    
17.      (if (member nm '("AcDbRay" "AcDbXline"))
    
18.        (setq box (mapcar 'getvar '("vsmin" "vsmax")))
    
19.        (progn (vla-GetBoundingBox (vlax-ename->vla-object e) 'll 'rr)
    
20.        (setq box (list (vlax-safearray->list ll)(vlax-safearray->list rr))
    
21.        )
    
22.        )
    
23.      )
    
24.      (setq ss (ssget "c" (car box) (cadr box) '((0 . "*LINE,ARC,RAY,CIRCLE,ELLIPSE"))))
    
25.      (command ".trim" ss "r" e "" "e" "n" (list e p) "");!!!
    
26.      (if (equal ee (setq ee2 (entlast)))
    
27.        nil
    
28.        (progn
    
29.   (setq nm2 (vla-get-objectname (vlax-ename->vla-object ee2))
    
30.         d11 (distance p (vlax-curve-getstartpoint e))
    
31.         d12 (if (= nm2 "AcDbRay")1e99(distance p (vlax-curve-getendpoint e)))
    
32.         d21 (distance p (vlax-curve-getstartpoint ee2))
    
33.         d22 (if (= nm2 "AcDbRay") 1e99(distance p (vlax-curve-getendpoint ee2)))
    
34.   )
    
35.   (if (member (min d11 d12 d21 d22) (list d11 d12))
    
36.     (entdel ee2)
    
37.     (entdel e)
    
38.   )
    
39.        )
    
40.      )
    
41.   )
    
42.   (princ)
    
43. )
    

<br /> ;| xt = 修剪曲线距最近交点点取边 --ok--by lxx.2007.2<br /> 功能: 以曲线与其它曲线最进交点为判断点,修剪曲线点取处的一边.<br /> |;<br /> (defun c:xt (/ A BOX D11 D12 D21 D22 E EE EE2 LL P RR SS nm nm2)<br />   (vl-load-com)<br />   (while<br />     (and<br />       (setq a (entsel))<br />       (setq e  (car a)<br />      nm (vla-get-objectname (vlax-ename->vla-object e))<br />       )<br />       (setq p (vlax-curve-getclosestpointto e (cadr a)))<br />     )<br />      (setq ee (entlast))<br />      (if (member nm '("AcDbRay" "AcDbXline"))<br />        (setq box (mapcar 'getvar '("vsmin" "vsmax")))<br />        (progn (vla-GetBoundingBox (vlax-ename->vla-object e) 'll 'rr)<br />        (setq box (list (vlax-safearray->list ll)(vlax-safearray->list rr))<br />        )<br />        )<br />      )<br />      (setq ss (ssget "c" (car box) (cadr box) '((0 . "*LINE,ARC,RAY,CIRCLE,ELLIPSE"))))<br />      (command ".trim" ss "r" e "" "e" "n" (list e p) "");!!!<br />      (if (equal ee (setq ee2 (entlast)))<br />        nil<br />        (progn<br />   (setq nm2 (vla-get-objectname (vlax-ename->vla-object ee2))<br />         d11 (distance p (vlax-curve-getstartpoint e))<br />         d12 (if (= nm2 "AcDbRay")1e99(distance p (vlax-curve-getendpoint e)))<br />         d21 (distance p (vlax-curve-getstartpoint ee2))<br />         d22 (if (= nm2 "AcDbRay") 1e99(distance p (vlax-curve-getendpoint ee2)))<br />   )<br />   (if (member (min d11 d12 d21 d22) (list d11 d12))<br />     (entdel ee2)<br />     (entdel e)<br />   )<br />        )<br />      )<br />   )<br />   (princ)<br /> )<br />

461045462

谢谢楼主的分享
收藏了,下来学习领会
谢谢

kexiya123

太有才了，支持，创意无限

faith66

狂刀哥大源码大奉送，多谢了，努力学习lisp

sy100

下载学习，谢谢分享！

meja

真的很不错啊

四叶草by

faith66 发表于 2011-5-12 20:31
狂刀哥大源码大奉送，多谢了，努力学习lisp

留个脚印。以备后用

myjping

这个更好一些
(defun C:ttr ( / edge ep i int line linename liness sp)
  (vl-load-com)
  (while (not edge)
    (setq edge (car (entsel "\n 请选择边界线:")))
    (redraw edge 3)
  )
  (prompt "\n 请选择需要extend或者trim的直线段: ")
  (if (setq i 0
            liness (ssget '((0 . "LINE")))
      )
    (repeat (sslength liness)
      (setq line (entget (ssname liness i))
            sp (cdr (assoc 10 line))
            ep (cdr (assoc 11 line))
      )
      (if (setq int (nth 0 (x_intlst edge (ssname liness i) acExtendOtherEntity)))
        (if (< (distance int sp) (distance int ep))
          (entmod (subst (cons 10 int)(assoc 10 line) line))
          (entmod (subst (cons 11 int) (assoc 11 line)line))
        )
      )
      (setq i (1+ i))
    )
    (princ "\n 没有找到需要被extend或者trim的直线段")
  )
  (redraw edge 4)
)
;;; by 狂刀 at xdcad
(defun x_intlst (obj1 obj2 param / intlst1 intlst2 ptlst)
  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param)))
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
        (setq ptlst (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
                          ptlst
                    )
              intlst2 (cdddr intlst2)
        )
      )
    )
  )
  ptlst
)

(princ "\n By qjchen@gmail.com, 有趣的trim和extend的结合，命令名:q")
(princ)

longer1000

myjping 发表于 2012-1-13 16:00
这个更好一些
(defun C:ttr ( / edge ep i int line linename liness sp)
  (vl-load-com)

最好加上多段线，

成仔

下载学习，谢谢分享！