动态拉伸LWPOLYLINE

marting · 发表于 2021-1-17 10:37:24

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(vl-load-com)
(defun c:dyst (/ +- ang ang0 dis
e ent epar gpt gpt1
grr i ind mpar n
o olderr par pt pt1
pt2 ptn pto pton spar
vlapto ss tpar jw-angle-curvept
jw-var->list cmdecho dynmode olderr
osmode
)
(princ
"\nDynamic stretch (For LWPOLYLINE,POLYLINE not closed) carrot1983 2008/11/25"
)
;;sub function
(defun jw-angle-curvept (ename pt / ang object tan)
(setq object (vlax-ename->vla-object ename))
(setq tan (vlax-curve-getfirstderiv
object
(vlax-curve-getparamatpoint object pt)
)
)
(setq
ang (if (= (car tan) 0)
(* 0.5 pi)
(angle (polar pt (atan (/ (cadr tan) (car tan))) 1) pt)
)
)
ang
)
(defun jw-var->list (var)
(if (= (type var) 'variant)
(vlax-safearray->list
(vlax-variant-value
var
)
)
)
)
(if (not olderr)
(setq olderr *error*)
)
(defun *error* (msg /)
(setq *error* olderr
olderr nil
)
(if osmode
(setvar "osmode" osmode)
)
(if dynmode
(setvar "dynmode" dynmode)
)
(if cmdecho
(setvar "cmdecho" cmdecho)
)
(princ msg)
(princ)
)
(command "._undo" "begin")
(setq cmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq osmode (getvar "osmode"))
(if (setq dynmode (getvar "dynmode"))
(setvar "dynmode" 0)
)
(setvar "osmode" 695)
(if (and (setq pt (getpoint "\nSelect the pline not closed: "))
(setq ss (ssget pt '((0 . "LWPOLYLINE,POLYLINE"))))
(setq e (ssname ss 0))
(setq o (vlax-ename->vla-object e))
(not (vlax-curve-isclosed o))
)
(progn
(setq spar (vlax-curve-getstartparam e))
(setq epar (vlax-curve-getendparam e))
(setq tpar (- epar spar))
(setq ang0 (jw-angle-curvept e pt))
(setq par (vlax-curve-getparamatpoint e pt))
(setq ind (fix par))
(setq mpar (* 0.5 (+ ind ind 1)))
(while (and (setq grr (grread t 4 0))
(or (= (car grr) 2)
(= (car grr) 5)
(= (car grr) 25)
)
)
(cond ((< par mpar) ;_param down 0-1-A-mp-2-3
(setq pt1 (vlax-curve-getpointatparam e ind))
(setq pt2 (vlax-curve-getpointatparam e (+ ind 1)))
(setq i 0)
(setq +- -)
(setq gpt (cadr grr))
(setq gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt)))
(setq pto (inters pt1 pt2 gpt gpt1 nil))
(setq dis (distance pt1 pto))
(setq ang (angle pt1 pto))
(repeat (fix (+ ind 1))
(setq n (+- ind i))
(setq ptn (jw-var->list (vla-get-coordinate o n)))
(setq pton (polar ptn ang dis))
(setq vlapto
(vlax-make-safearray vlax-vbdouble '(0 . 1))
)
(vlax-safearray-fill vlapto pton)
(vla-put-coordinate o n vlapto)
(setq i (1+ i))
)
)
((>= par mpar) ;_param up 0-1-mp-A-2-3
(setq pt2 (vlax-curve-getpointatparam e ind))
(setq pt1 (vlax-curve-getpointatparam e (+ ind 1)))
(setq i 1)
(setq +- +)
(setq gpt (cadr grr))
(setq gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt)))
(setq pto (inters pt1 pt2 gpt gpt1 nil))
(setq dis (distance pt1 pto))
(setq ang (angle pt1 pto))
(repeat (fix (- tpar ind))
(setq n (+- ind i))
(setq ptn (jw-var->list (vla-get-coordinate o n)))
(setq pton (polar ptn ang dis))
(setq vlapto
(vlax-make-safearray vlax-vbdouble '(0 . 1))
)
(vlax-safearray-fill vlapto pton)
(vla-put-coordinate o n vlapto)
(setq i (1+ i))
)
)
)
)
)
(princ "\nPlease retry!!!")
)
(if dynmode
(setvar "dynmode" dynmode)
)
(setvar "osmode" osmode)
(setq *error* olderr)
(setvar "cmdecho" cmdecho)
(command "._undo" "end")
(princ)
)

(vl-load-com) 
(defun c:dyst (/              +-       ang        ang0         dis 
                     e              ent      epar        gpt         gpt1 
                     grr      i               ind        mpar         n 
                     o              olderr   par        pt         pt1 
                     pt2      ptn      pto        pton         spar 
                     vlapto   ss       tpar        jw-angle-curvept 
                     jw-var->list      cmdecho        dynmode         olderr 
                     osmode 
                    ) 
  (princ 
    "\nDynamic stretch (For LWPOLYLINE,POLYLINE not closed) carrot1983 2008/11/25" 
  ) 
  ;;sub function 
  (defun jw-angle-curvept (ename pt / ang object tan) 
    (setq object (vlax-ename->vla-object ename)) 
    (setq tan (vlax-curve-getfirstderiv 
                object 
                (vlax-curve-getparamatpoint object pt) 
              ) 
    ) 
    (setq 
      ang (if (= (car tan) 0) 
            (* 0.5 pi) 
            (angle (polar pt (atan (/ (cadr tan) (car tan))) 1) pt) 
          ) 
    ) 
    ang 
  ) 
 
  (defun jw-var->list (var) 
    (if        (= (type var) 'variant) 
      (vlax-safearray->list 
        (vlax-variant-value 
          var 
        ) 
      ) 
    ) 
  ) 
 
  (if (not olderr) 
    (setq olderr *error*) 
  ) 
  (defun *error* (msg /) 
    (setq *error* olderr 
          olderr  nil 
    ) 
    (if        osmode 
      (setvar "osmode" osmode) 
    ) 
    (if        dynmode 
      (setvar "dynmode" dynmode) 
    ) 
    (if        cmdecho 
      (setvar "cmdecho" cmdecho) 
    ) 
    (princ msg) 
    (princ) 
  ) 
 
  (command "._undo" "begin") 
  (setq cmdecho (getvar "cmdecho")) 
  (setvar "cmdecho" 0) 
  (setq osmode (getvar "osmode")) 
  (if (setq dynmode (getvar "dynmode")) 
    (setvar "dynmode" 0) 
  ) 
  (setvar "osmode" 695) 
  (if (and (setq pt (getpoint "\nSelect the pline not closed: ")) 
           (setq ss (ssget pt '((0 . "LWPOLYLINE,POLYLINE")))) 
           (setq e (ssname ss 0)) 
           (setq o (vlax-ename->vla-object e)) 
           (not (vlax-curve-isclosed o)) 
      ) 
    (progn 
 
      (setq spar (vlax-curve-getstartparam e)) 
      (setq epar (vlax-curve-getendparam e)) 
      (setq tpar (- epar spar)) 
      (setq ang0 (jw-angle-curvept e pt)) 
      (setq par (vlax-curve-getparamatpoint e pt)) 
      (setq ind (fix par)) 
      (setq mpar (* 0.5 (+ ind ind 1))) 
 
      (while (and (setq grr (grread t 4 0)) 
                  (or (= (car grr) 2) 
                      (= (car grr) 5) 
                      (= (car grr) 25) 
                  ) 
             ) 
        (cond ((< par mpar) ;_param down 0-1-A-mp-2-3 
               (setq pt1 (vlax-curve-getpointatparam e ind)) 
               (setq pt2 (vlax-curve-getpointatparam e (+ ind 1))) 
               (setq i 0) 
               (setq +- -) 
               (setq gpt (cadr grr)) 
               (setq gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))) 
               (setq pto (inters pt1 pt2 gpt gpt1 nil)) 
               (setq dis (distance pt1 pto)) 
               (setq ang (angle pt1 pto)) 
               (repeat (fix (+ ind 1)) 
                 (setq n (+- ind i)) 
                 (setq ptn (jw-var->list (vla-get-coordinate o n))) 
                 (setq pton (polar ptn ang dis)) 
                 (setq vlapto 
                        (vlax-make-safearray vlax-vbdouble '(0 . 1)) 
                 ) 
                 (vlax-safearray-fill vlapto pton) 
                 (vla-put-coordinate o n vlapto) 
                 (setq i (1+ i)) 
               ) 
              ) 
 
              ((>= par mpar) ;_param up 0-1-mp-A-2-3 
               (setq pt2 (vlax-curve-getpointatparam e ind)) 
               (setq pt1 (vlax-curve-getpointatparam e (+ ind 1))) 
               (setq i 1) 
               (setq +- +) 
               (setq gpt (cadr grr)) 
               (setq gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))) 
               (setq pto (inters pt1 pt2 gpt gpt1 nil)) 
               (setq dis (distance pt1 pto)) 
               (setq ang (angle pt1 pto)) 
               (repeat (fix (- tpar ind)) 
                 (setq n (+- ind i)) 
                 (setq ptn (jw-var->list (vla-get-coordinate o n))) 
                 (setq pton (polar ptn ang dis)) 
                 (setq vlapto 
                        (vlax-make-safearray vlax-vbdouble '(0 . 1)) 
                 ) 
                 (vlax-safearray-fill vlapto pton) 
                 (vla-put-coordinate o n vlapto) 
                 (setq i (1+ i)) 
               ) 
              ) 
        ) 
      ) 
    ) 
    (princ "\nPlease retry!!!") 
  ) 
  (if dynmode 
    (setvar "dynmode" dynmode) 
  ) 
  (setvar "osmode" osmode) 
  (setq *error* olderr) 
  (setvar "cmdecho" cmdecho) 
  (command "._undo" "end") 
  (princ) 
)

xxchemkin · 发表于 2021-1-17 10:43:20

谢谢分享代码，还在学习中。

dmxcs · 发表于 2021-1-18 00:39:08

拉板筋很好

chaozi5756 · 发表于 2021-1-18 11:14:57

能不能按长度或者按比例收放

newer · 发表于 2021-1-18 11:21:17

chaozi5756 发表于 2021-1-18 11:14
能不能按长度或者按比例收放

这个是拉伸顶点，不是缩放
你要想缩放，可以去编程申请论坛发个帖子说下需求

zwwen12 · 发表于 2021-1-18 11:52:25

如能有捕捉功能或者输入数字功能就完善了

bzhjl · 发表于 2021-1-18 21:50:38

动图好评[哈哈]学习中[抱拳]

Herealone · 发表于 2021-1-22 10:33:04

谢谢分享~~~~~

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

[每日一码] 动态拉伸LWPOLYLINE

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评