(已解决）拉伸程序修改

123456abc 发表于 2014-3-1 12:11:50

本帖最后由 123456abc 于 2014-3-1 17:47 编辑

下面是一组从网上获取的拉伸程序，执行后提示错误：错误: 无法获取 ObjectID: nil，请高手帮忙改进一下，多谢！！

(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)
)

孙玉坤 发表于 2025-10-24 03:59:03

Andyhon 发表于 2014-3-1 13:12
应是注解部份的干扰...

大师您好能加个捕捉不:lol

flowerson 发表于 2020-3-15 16:01:56

edata 发表于 2014-3-1 17:31
要选择不低于三点的多段线

能不能实现有捕捉？

wolaixuexi 发表于 2019-9-19 13:50:04

很强大，只是能加上捕捉就更好了

Andyhon 发表于 2014-3-1 13:12:20

应是注解部份的干扰...

123456abc 发表于 2014-3-1 15:08:35

还是不能用，一样的错误啊

edata 发表于 2014-3-1 17:31:16

要选择不低于三点的多段线

;|
*************************************************************************************************
*    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
*************************************************************************************************
|;

(defun c:ofss (/ E G O P1 P2 V1 V2 V3) ;
(vl-load-com)
(prompt "\n选择不低于三点的多段线:")
(setq e (entsel))
(if (and e (= (cdr(assoc 0 (entget (car e)))) "LWPOLYLINE"))
   (progn
(setq
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)
)

123456abc 发表于 2014-3-1 17:46:54

恩，确实是要选三点，多谢

tangjunasd58 发表于 2014-11-14 00:23:32

怎么才能让这个程序有捕捉

enn09 发表于 2014-11-14 09:07:46

这个不是太好用，不能按照距离拉伸

wolaixuexi 发表于 2019-9-3 10:55:31

很强大，只是能加上捕捉就更好了

页: [1] 2

明经CAD社区's Archiver

(已解决）拉伸程序修改