[LISP程序]：结合trim和extend的有趣程序

snoopychen

一个还算有趣的trim和extend的结合，不记得论坛是不是有写过
针对一个修剪边和一堆直线自动进行trim或者extend，相交的直线按照
修剪边两边的长度，取长者保留。
这个是今天在http://intervision.hjem.wanadoo.dk/看到的程序
作者原来程序中作为修剪边的对象只能是直线，（因为用的是纯lisp
的inter函数），为了修剪边可以复杂一些，我稍作修改，用了陌生人
长老的x_intlst实体交点子程序，不过现在r14就不可以用了。
这个程序应该可以继续改进的，对修剪对象扩展为其他类型，不过这时候
应该就得用到vlax-curve-getParamAtDist之类来判断线应该留下哪一边
之类了。

代码如下
[php]
;;; 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
)
[/php]

狂刀

求实交点，如果有实交点，剪切端点近的一边
如果无实交点，延伸端点近的一边

zhuxiaoming

加载后使用时怎么提示No objects found