【已解决】求助：延伸然后剪切相交程序

丽丽星空

框选4根线，然后完成相交剪切，求大侠帮忙。谢谢！

丽丽星空

自己顶起！

丽丽星空

还是自己来！
在版主XIAOXIANG提供的源码基础上修改而来，原帖见http://bbs.mjtd.com/forum.php?mod=viewthread&tid=92533&page=3#pid512194

1. (defun c:tt ()
   
2.   (defun *error* (msg)
   
3.   (if  bound1 (redraw bound1 4))
   
4.   (princ msg)      
   
5.   (princ)
   
6.   )
   
7.   (vl-load-com)
   
8.   (or *acdoc*
   
9.       (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
   
10.   )
    
11. (setq i 0)
    
12.   
    
13.   (if (and (setq bound (car (clh-entsel "\n选电气桥架直线: " ":S" '((8 . "电-*") (0 . "LINE")) "\n非电气桥架直线：" ))) (setq bound1 bound)
    
14.     (setq bound (vlax-ename->vla-object bound))
    
15.       )
    
16. (progn
    
17.     (redraw bound1 3)
    
18.    
    
19.     (if (ssget '((0 . "LINE") (8 . "电-*")))
    
20.       (progn
    
21. (vla-StartUndoMark *acdoc*)
    
22. (vlax-for l (vla-get-ActiveSelectionSet *acdoc*)
    
23.    (setq int (vlax-invoke bound 'IntersectWith l acExtendOtherEntity))
    
24.    
    
25.      (if (= i 0)
    
26.         (setq pt1 int)
    
27. (setq pt2 int)
    
28. )
    
29.        (setq i (+ i 1))
    
30.    (while int
    
31.          
    
32.      (setq pt  (list (car int) (cadr int) (caddr int))
    
33.     int (cdddr int)
    
34.      )
    
35.      (if (< (distance (vlax-get l 'StartPoint) pt)
    
36.      (distance (vlax-get l 'EndPoint) pt)
    
37.   )
    
38.        (vlax-put l 'StartPoint pt)
    
39.        (vlax-put l 'EndPoint pt)
    
40.      )
    
41.    )
    
42. )
    
43. (COMMAND "BREAK" bound1 pt1 pt2)
    
44. (vla-EndUndoMark *acdoc*)
    
45.       )
    
46.     ))
    
47.   )
    
48.   (redraw bound1 4)
    
49.   (princ)
    
50. )
    
51. 
    
52. ;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel
    
53. ;;用法：( clh-entsel  提示信息  关键字  过滤表  选择错误时提示)
    
54. ;;举例：(clh-entsel  "\n请选择一个圆："  "A B C"   '((0 . "circle"))  "\n所选对像不符合要求！请重新选择：")
    
55. ;;说明：过滤表与ssget的过滤表相同
    
56. (defun clh-entsel (msg key fil ermsg / el ss)
    
57.   (while (and (setvar "errno" 0)
    
58.            (not (and (setq el (apply '(lambda (msg key) (initget key) (entsel msg)) (list msg key)))
    
59.             (if (= (type el) 'str)
    
60.                 el
    
61.             (if (setq ss (ssget (cadr el) fil))
    
62.                ss
    
63.             (progn (princ ermsg) (setq ss nil))
    
64.             );if
    
65.          );if
    
66.      );and
    
67.      );not
    
68.      (/= (getvar "errno") 52)
    
69.    );and
    
70.   );while
    
71.    el
    
72. )
    
73. 
    

(defun c:tt ()<br />   (defun *error* (msg)<br />   (if  bound1 (redraw bound1 4)) <br />   (princ msg)      <br />   (princ) <br />   )<br />   (vl-load-com)<br />   (or *acdoc*<br />       (setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))<br />   )<br /> (setq i 0)<br />   <br />   (if (and (setq bound (car (clh-entsel "\n选电气桥架直线: " ":S" '((8 . "电-*") (0 . "LINE")) "\n非电气桥架直线：" ))) (setq bound1 bound)<br />     (setq bound (vlax-ename->vla-object bound)) <br />       )<br /> (progn<br />     (redraw bound1 3)<br />     <br />     (if (ssget '((0 . "LINE") (8 . "电-*")))<br />       (progn<br /> (vla-StartUndoMark *acdoc*)<br /> (vlax-for l (vla-get-ActiveSelectionSet *acdoc*)<br />    (setq int (vlax-invoke bound 'IntersectWith l acExtendOtherEntity))<br />    <br />      (if (= i 0)<br />         (setq pt1 int)<br /> (setq pt2 int)<br /> )<br />        (setq i (+ i 1))<br />    (while int<br />           <br />      (setq pt  (list (car int) (cadr int) (caddr int))<br />     int (cdddr int)<br />      )<br />      (if (< (distance (vlax-get l 'StartPoint) pt)<br />      (distance (vlax-get l 'EndPoint) pt)<br />   )<br />        (vlax-put l 'StartPoint pt)<br />        (vlax-put l 'EndPoint pt)<br />      )<br />    )<br /> )<br /> (COMMAND "BREAK" bound1 pt1 pt2)<br /> (vla-EndUndoMark *acdoc*)<br />       )<br />     ))<br />   )<br />   (redraw bound1 4)<br />   (princ)<br /> )<br /> <br /> ;;功能：带提示、关键字、过滤表、选择错误时的提示并且会亮显所选对像的entsel<br /> ;;用法：( clh-entsel  提示信息  关键字  过滤表  选择错误时提示)<br /> ;;举例：(clh-entsel  "\n请选择一个圆："  "A B C"   '((0 . "circle"))  "\n所选对像不符合要求！请重新选择：")<br /> ;;说明：过滤表与ssget的过滤表相同<br /> (defun clh-entsel (msg key fil ermsg / el ss)<br />   (while (and (setvar "errno" 0) <br />            (not (and (setq el (apply '(lambda (msg key) (initget key) (entsel msg)) (list msg key)))<br />             (if (= (type el) 'str)<br />                 el<br />             (if (setq ss (ssget (cadr el) fil))<br />                ss<br />             (progn (princ ermsg) (setq ss nil))<br />             );if<br />          );if<br />      );and<br />      );not<br />      (/= (getvar "errno") 52)<br />    );and<br />   );while<br />    el<br /> )<br /> <br />