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

丽丽星空 · 发表于 2013-12-9 19:21

本帖最后由丽丽星空于 2014-2-21 17:01 编辑

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

丽丽星空 · 发表于 2013-12-10 16:34

自己顶起！

丽丽星空 · 发表于 2014-2-21 16:51

本帖最后由丽丽星空于 2014-2-21 16:58 编辑

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

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

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

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

相关帖子

点评