[autolisp] 有趣的trim和extend的结合.lsp

[code]
;;; 有趣的trim和extend的结合 *
;;; 初始创意Stig Madsen *
;;; 用途，选择一根直线，再选择其他直线段Line， *
;;; 后选Line会自动延伸extend或者修剪trim *
;;; qjchen之修改，重写大部分代码，将边界线改为更多类型 *
;;; 之中使用了 xdcad 狂刀的求两物体交点的代码，谢谢狂刀兄 *
(defun C:q ( / 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)
[/code]