(已解决）拉伸程序修改

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

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

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

能不能实现有捕捉？

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

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

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

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

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

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

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

账号		自动登录	找回密码
密码			注册

[提问] (已解决）拉伸程序修改

相关帖子

本帖子中包含更多资源

评分

浏览过的版块