求助，网上有一快速拉伸程序，请完善能输入数字，达到精确拉伸距离！

cxs259

(defun c:ofss (/ E G O P1 P2 V1 V2 V3)
              ;|
*************************************************************************************************
*
*        by ElpanovEvgeniy 26.02.2010
*
*        ----------------
*        27.02.2010 8:30
*        fix bug for acad 2004 (vlax-curve-getFirstDeriv e (vlax-curve-getEndParam e))
*        ----------------
*        27.02.2010 8:55
*        fix bug for first arc segment
*************************************************************************************************
|;
(setq e  (entsel)
       p1 (cadr e)
       e  (car e)
       p1 (fix (vlax-curve-getParamAtPoint e (vlax-curve-getClosestPointTo e p1)))
       o  (vlax-ename->vla-object e)
) ;_  setq
(if (= 1 (cdr (assoc 70 (entget e))))
  (cond ((zerop p1)
         (setq p2 (1+ p1)
               v1 (list (vlax-curve-getPointAtParam e (vlax-curve-getEndParam e))
                        (vlax-curve-getFirstDeriv e (1- (vlax-curve-getEndParam e)))
                  ) ;_  list
               v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e 0.5))
               v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e 1.5))
         ) ;_  setq
        )
        ((= p1 (1- (vlax-curve-getEndParam e)))
         (setq p2 0
               v1 (list (vlax-curve-getPointAtParam e (1- p1))
                        (vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
                  ) ;_  list
               v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
               v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
         ) ;_  setq
        )
        ((setq p2 (1+ p1)
               v1 (list (vlax-curve-getPointAtParam e (1- p1))
                        (vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
                  ) ;_  list
               v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
               v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
         ) ;_  setq
        )
  ) ;_  cond
  (cond ((zerop p1)
         (setq p2 (1+ p1)
               v2 (list (vlax-curve-getPointAtParam e 0) (vlax-curve-getFirstDeriv e 0.5))
               v1 (list (car v2) (list (cadadr v2) (- (caadr v2)) 0.))
               v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e 1.5))
         ) ;_  setq
        )
        ((= p1 (1- (vlax-curve-getEndParam e)))
         (setq p2 (vlax-curve-getEndParam e)
               v1 (list (vlax-curve-getPointAtParam e (1- p1))
                        (vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
                  ) ;_  list
               v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
               v3 (list (vlax-curve-getPointAtParam e p2) (list (cadadr v2) (- (caadr v2)) 0.))
         ) ;_  setq
        )
        ((setq p2 (1+ p1)
               v1 (list (vlax-curve-getPointAtParam e (1- p1))
                        (vlax-curve-getFirstDeriv e (+ (1- p1) 0.5))
                  ) ;_  list
               v3 (list (vlax-curve-getPointAtParam e p2) (vlax-curve-getFirstDeriv e (+ p2 0.5)))
               v2 (list (vlax-curve-getPointAtParam e p1) (vlax-curve-getFirstDeriv e (+ p1 0.5)))
         ) ;_  setq
        )
  ) ;_  cond
) ;_  if
(while (= (car (setq g (grread nil 5 0))) 5)
  (vla-put-coordinate
   o
   p1
   (vlax-make-variant
    (vlax-safearray-fill (vlax-make-safearray 5 '(0 . 1))
                         (reverse (cdr (reverse (inters (car v1)
                                                        (mapcar '+ (car v1) (cadr v1))
                                                        (cadr g)
                                                        (mapcar '+ (cadr g) (cadr v2))
                                                        nil
                                                ) ;_  inters
                                       ) ;_  reverse
                                  ) ;_  cdr
                         ) ;_  reverse
    ) ;_  vlax-safearray-fill
   ) ;_  vlax-make-variant
  ) ;_  vla-put-coordinate
  (vla-put-coordinate
   o
   p2
   (vlax-make-variant
    (vlax-safearray-fill (vlax-make-safearray 5 '(0 . 1))
                         (reverse (cdr (reverse (inters (car v3)
                                                        (mapcar '+ (car v3) (cadr v3))
                                                        (cadr g)
                                                        (mapcar '+ (cadr g) (cadr v2))
                                                        nil
                                                ) ;_  inters
                                       ) ;_  reverse
                                  ) ;_  cdr
                         ) ;_  reverse
    ) ;_  vlax-safearray-fill
   ) ;_  vlax-make-variant
  ) ;_  vla-put-coordinate
) ;_  while
(princ)
)

hgf876

可以用我的命令看看，不知是不是满足要求。
http://bbs.mjtd.com/thread-92145-1-1.html