LISP程序BUG帮忙解决下！

wowan1314

这是关于TRIM与EXTEND的LISP。使CAD2004实现2006一样的框选功能！但是发现有BUG！如果使用不当会把对象捕捉的设置清除！ 很是苦恼！ 请哪个大哥帮忙看看！能否改下！ 如果能再加上个命令使点中曲线，单点剪切；点于空位就狂选！完全跟CAD2006一样那就最好了！

下面是LISP文件

;(if (< (atof (substr (getvar "acadver") 1 4)) 16.2)
; (progn
;;--------------------------------------------------

(defun trim&extend (cmd / error error_end olderr ssget-g ssRedraw cm os ss1 ss2 lst)
   (if cmd
     (setq cmd "_.trim")
     (setq cmd "_.extend")
   )
   (defun error (x) (error_end))
   (defun error_end ()
     (if ss1 (ss-Redraw ss1 4))
     (if cm (setvar "cmdecho" cm))
     (if os (setvar "osmode" os))
     (setq *error* olderr)
   )
   (setq olderr *error* *error* error)
   (defun ss-Redraw (ss mode)
     (mapcar '(lambda (x) (redraw x mode))
             (vl-remove-if-not '(lambda (x) (= (type x) 'ename)) (mapcar 'cadr (ssnamex ss)))
     )
   )
   (setq cm (getvar "cmdecho")
         os (getvar "osmode")
   )
   (setvar "cmdecho" 0)
   (setvar "osmode" 0)
   (defun ssget-g (msg fit / p1 p2 ss)
     (if (not msg) (setq msg "\n选择对象: "))
     (setq p1 (getpoint msg))
     (if p1
       (progn
         (setq p2 (getcorner p1 "指定对角点: "))
         (while (not p2)
           (if (not p2) (princ "窗口说明无效。"))
           (setq p2 (getcorner p1 (strcat msg "指定对角点: ")))
         )
         (setq ss (ssget "_c" p1 p2 fit))
       )
     )
     (list ss p1 p2)
   )
   (princ "\n选择剪切边或 <全部选择>... ")
   (setq ss1 (ssget))
   (while
     (progn
       (if ss1 (ss-redraw ss1 3))
       (apply 'or (setq lst (cdr (setq ss2 (ssget-g "\n选择要修剪的对象: " nil)))))
     )
     (if (car ss2)
       (progn
         (setq lst (list (car lst)
                         (cons (caar lst) (cdadr lst))
                         (cadr lst)
                         (cons (caadr lst) (cdar lst))
                         (car lst)
                   )
         )
         (command cmd)
         (if ss1 (command ss1 "") (command ""))
         (command "_f")
         (apply 'command lst)
         (command "" "")
       )
     )
   )
   (error_end)
   (princ)
)

(defun c:w () (trim&extend T))
(defun c:z () (trim&extend nil))

;;--------------------------------------------------
; )
   (princ)
;)

zml84

这里有一篇，希望对你有所帮助。
http://zml84.blog.sohu.com/63944569.html