一个还算有趣的trim和extend的结合，不记得论坛是不是有写过
针对一个修剪边和一堆直线自动进行trim或者extend，相交的直线按照
修剪边两边的长度，取长者保留。
这个是今天在http://intervision.hjem.wanadoo.dk/看到的程序
作者原来程序中作为修剪边的对象只能是直线，（因为用的是纯lisp
的inter函数），为了修剪边可以复杂一些，我稍作修改，用了陌生人
长老的x_intlst实体交点子程序，不过现在r14就不可以用了。
这个程序应该可以继续改进的，对修剪对象扩展为其他类型，不过这时候
应该就得用到vlax-curve-getParamAtDist之类来判断线应该留下哪一边
之类了。
代码如下
;;; Touch.LSP *
;;; Small routine to align endpoints of lines to an edge. *
;;; The edge have to be a line. *
;;; The routine works by calculating the point of inter- *
;;; section and change the nearest endpoint to that point *
;;; 2001 Stig Madsen, no rights reserved *
;;; modified by qjchen
(defun C:Ttt (/ cmd ent entl spt ept sset a lent lentl lspt lept lint)
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "UNDO" "Begin")
(while (not ent)
(setq ent (car (entsel "Select edge line: ")))
(if ent
(progn
(setq entl (entget ent))
)
)
)
(if ent
(progn
(redraw ent 3)
(prompt "\nSelect lines to touch edge: ")
(setq sset (ssget '((0 . "LINE")))
a 0
)
(if sset
(repeat (sslength sset)
(setq lentl (entget (setq lent (ssname sset a)))
lspt (cdr (assoc 10 lentl))
lept (cdr (assoc 11 lentl))
)
(setq entttt (ssname sset a))
(setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
(if lint
(progn
(if (< (distance lint lspt) (distance lint lept))
(entmod (subst
(cons 10 lint)
(assoc 10 lentl)
lentl
)
)
(entmod (subst
(cons 11 lint)
(assoc 11 lentl)
lentl
)
)
)
)
)
(setq a (1+ a))
)
(princ "\nNo objects found")
)
(redraw ent 4)
)
(princ "\nNo edge selected")
)
(setvar "CMDECHO" cmd)
(command "UNDO" "End")
(princ)
)
;;; by 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
)
家园首页·
下载中心·
图纸中心·
文章中心·
教学中心·
晓东词典·
资源中心·
FTP联盟·
校友录·
邮购服务
家园首页 >> 家园论坛 > 
…编程开发版块 > ※AutoLISP/VLISP 开发技术※ > [LISP程序]：结合trim和extend的有趣程序
