分享个好程序，同时求程序合并

半听可乐

之前一直在用动态拉长普通直线的程序（下面第一个），最近搜集到动态拉长多义线的程序，感觉都很实用，哪位大侠能把下面两个程序合并一下，使之成为通杀直线动态拉长？即使用时根据选择直线的类型自动判断运行哪个程序
；DB_LENGDY  动态拉长line
(DEFUN C:DB_LENGDY ()
(COMMAND "LENGTHEN" "DY") (PRINC))


;不封闭的多义线动态拉伸dyst
(defun c:dyst ( / old_cmd +- ang ang0 dis
       e       ent      epar gpt  gpt1
       grr      i        ind mpar  n
       o par pt  pt1
       pt2      ptn      pto spar
       vlapto   ss       tpar
       times
      )
  (mini_start nil)
  (princ "\n不封闭的多义线动态拉伸 carrot1983 2008/11/25")
  (if (and (setq pt (entsel "\n选择不封闭的多义线:"))
        (setq e (car pt)
              pt (cadr pt)
              o (vlax-ename->vla-object e)
     )
        (= (vlax-get-property o 'ObjectName) "AcDbPolyline")
        (not (vlax-curve-isclosed o))
      )
    (progn
      (setq pt (vlax-curve-getClosestPointTo o (trans pt 1 0))
         spar (vlax-curve-getstartparam e)
            epar (vlax-curve-getendparam e)
            tpar (- epar spar)
            par (vlax-curve-getparamatpoint o pt)
      ang0 (vlax-curve-getfirstderiv o par)
      ang0 (angle '(0 0) (list (car ang0) (cadr ang0)))
            ind (fix par)
            mpar (+ ind 0.5)
   )
      (while (and (setq grr (grread t 4 0))
            (member (car grr) (list 2 5 25))
          )
          (setq pt1 (vlax-curve-getpointatparam e ind)
                pt2 (vlax-curve-getpointatparam e (+ ind 1))
       )
          (if (< par mpar)
              (setq i 0 +- - times (+ ind 1))
              (setq i pt1 pt1 pt2 pt2 i i 1 +- + times (fix (- tpar ind)))
          )
          (setq gpt (cadr grr)
                gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
                pto (inters pt1 pt2 gpt gpt1 nil)
                dis (distance pt1 pto)
                ang (angle pt1 pto)
       )
          (repeat times
          (setq n (+- ind i)
                i (1+ i)
       ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate o n)))
                vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))
          )
          (vlax-safearray-fill vlapto (polar ptn ang dis))
          (vla-put-coordinate o n vlapto)
         )
      )
    )
  )
  (mai_end)
)

wudechao

;完美版本,经过长时间修改完善,支持直线,圆弧,椭圆弧,多义线,并在ucs座标系下也可以运行.
(defun c:dyst (/ *error* oos oor en point ent dxf p1 p2 dis1 dis2 n pt per-pt ptold cen rad angle0 angle1
               angle2 angle3 maj rat r1 r2 a b ent2 ratio spar epar tpar par ang0 ind mpar grr pt1 pt2 i
               +- times gpt gpt1 ptmid pt0 ptn dis ang vlapto js1 js2
            )
(vl-load-com)
(setvar "cmdecho" 0)
(defun *error* (msg)
  (if oos
   (setvar "osmode" oos)
  )
  (if oor
   (setvar "orthomode" oor)
  )
)
(setq oor (getvar "orthomode")
       oos (getvar "osmode")
)
(setvar "orthomode" 0)
(setvar "osmode" 0)
(while (setq en (entsel "\n选择要修改的对象或 [放弃(U)]:"))
  (if (= "LINE" (cdr (assoc 0 (entget (car en)))))
   (progn
    (prompt (strcat "\n指定新端点:"))
    (setq point (osnap (cadr en) "nea"))
    (setq ent (car en))
    (setq dxf (entget ent))
    (setq p1 (cdr (assoc 10 dxf))
          p1 (trans p1 0 1)
          p2 (cdr (assoc 11 dxf))
          p2 (trans p2 0 1)
    )
    (setq dis1 (distance p1 point)
          dis2 (distance p2 point)
    )
    (while (/= 3 (car (setq n (grread t 4 3))))
     (setq pt (cadr n))
     (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
     (setq per-pt (trans per-pt 1 0))
     (if ptold
      (grdraw point ptold 0)
     )
     (grdraw point pt 7)
     (setq ptold pt)
     (if (>= dis1 dis2)
      (progn
       (setq dxf (subst
                  (cons 11 per-pt)
                  (assoc 11 dxf)
                  dxf
                 )
       )
      )
      (progn
       (setq dxf (subst
                  (cons 10 per-pt)
                  (assoc 10 dxf)
                  dxf
                 )
       )
      )
     )
     (entmod dxf)
    )
    (grdraw point ptold 0)
   )
  )
  (if (= "ARC" (cdr (assoc 0 (entget (car en)))))
   (progn
    (prompt (strcat "\n指定新端点:"))
    (setq point (osnap (cadr en) "nea"))
    (setq ent (car en))
    (setq dxf (entget ent))
    (setq cen (cdr (assoc 10 dxf))
          rad (cdr (assoc 40 dxf))
          angle1 (cdr (assoc 50 dxf))
          angle2 (cdr (assoc 51 dxf))
          p1 (polar cen angle1 rad)
          p1 (trans p1 0 1)
          p2 (polar cen angle2 rad)
          p2 (trans p2 0 1)
          dis1 (distance p1 point)
          dis2 (distance p2 point)
    )
    (while (/= 3 (car (setq n (grread t 4 3))))
     (setq pt (cadr n))
     (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
     (setq per-pt (trans per-pt 1 0))
     (setq per-pt (angle cen per-pt))
     (if ptold
      (grdraw point ptold 0)
     )
     (grdraw point pt 7)
     (setq ptold pt)
     (if (>= dis1 dis2)
      (progn
       (setq dxf (subst
                  (cons 51 per-pt)
                  (assoc 51 dxf)
                  dxf
                 )
       )
      )
      (progn
       (setq dxf (subst
                  (cons 50 per-pt)
                  (assoc 50 dxf)
                  dxf
                 )
       )
      )
     )
     (entmod dxf)
    )
    (grdraw point ptold 0)
   )
  )
  (if (= "ELLIPSE" (cdr (assoc 0 (entget (car en)))))
   (progn
    (prompt (strcat "\n指定新端点:"))
    (setq point (osnap (cadr en) "nea"))
    (setq ent (car en))
    (setq dxf (entget ent))
    (setq cen (cdr (assoc 10 dxf))
          maj (cdr (assoc 11 dxf))
          rat (cdr (assoc 40 dxf))
          a (distance (quote (0 0)) maj)
          b (* a rat)
          angle0 (angle (quote (0 0)) maj)
          angle1 (cdr (assoc 41 dxf))
          angle2 (cdr (assoc 42 dxf))
    )
    (setq r1 (/ (* a b) (sqrt (+ (expt (* b (cos angle1)) 2) (expt (* a (sin angle1)) 2)))))
    (setq r2 (/ (* a b) (sqrt (+ (expt (* b (cos angle2)) 2) (expt (* a (sin angle2)) 2)))))
    (setq angle1 (+ angle1 angle0)
          angle2 (+ angle2 angle0)
          point (trans point 1 0)
          dis1 (distance (polar cen angle1 r1) point)
          dis2 (distance (polar cen angle2 r2) point)
          point (trans point 0 1)
    )
    (while (/= 3 (car (setq n (grread t 4 3))))
     (setq pt (cadr n))
     (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
     (setq per-pt (trans per-pt 1 0)
           angle3 (angle cen per-pt)
     )
     (if (< angle3 angle1)
      (setq angle3 (+ angle3 (* 2 pi)))
     )
     (setq per-pt (- angle3 angle0))
     (if ptold
      (grdraw point ptold 0)
     )
     (grdraw point pt 7)
     (setq ptold pt)
     (if (>= dis1 dis2)
      (progn
       (setq dxf (subst
                  (cons 42 per-pt)
                  (assoc 42 dxf)
                  dxf
                 )
       )
      )
      (progn
       (setq dxf (subst
                  (cons 41 per-pt)
                  (assoc 41 dxf)
                  dxf
                 )
       )
      )
     )
     (entmod dxf)
    )
    (grdraw point ptold 0)
   )
  )
  (if (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))
   (progn
    (prompt (strcat "\n指定新端点:"))
    (setq point (osnap (cadr en) "nea"))
    (setq pt en)
    (setq e (car pt)
          pt0 (cadr pt)
          ent2 (vlax-ename->vla-object e)
    )
    (if (and
         (= (vlax-get-property ent2 (quote objectname)) "AcDbPolyline")
         (not (vlax-curve-isclosed ent2))
        )
     (progn
      (setq pt0 (vlax-curve-getclosestpointto ent2 (trans pt0 1 0))
            spar (vlax-curve-getstartparam e)
            epar (vlax-curve-getendparam e)
            tpar (- epar spar)
            par (vlax-curve-getparamatpoint ent2 pt0)
            ang0 (vlax-curve-getfirstderiv ent2 par)
            ang0 (angle (quote (0 0)) (list (car ang0) (cadr ang0)))
            ind (fix par)
            mpar (+ ind 0.5)
      )
      (while (and
              (setq grr (grread t 4 0))
              (member (car grr) (list 2 5 25))
             )
       (setq pt1 (vlax-curve-getpointatparam e ind)
             pt2 (vlax-curve-getpointatparam e (+ ind 1))
       )
       (if (< par mpar)
        (setq i 0
              +- -
              times (+ ind 1)
        )
        (setq i pt1
              pt1 pt2
              pt2 i
              i 1
              +- +
              times (fix (- tpar ind))
        )
       )
       (setq gpt (cadr grr)
             gpt (trans gpt 1 0)
             gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
             ptmid (inters
                    pt1
                    pt2
                    gpt
                    gpt1
                    nil
                   )
             dis (distance pt1 ptmid)
             ang (angle pt1 ptmid)
       )
       (setq gpt (trans gpt 0 1))
       (if ptold
        (grdraw point ptold 0)
       )
       (grdraw point gpt 7)
       (setq ptold gpt)
       (repeat times
        (setq n (+- ind i)
              i (1+ i)
              ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate ent2 n)))
              vlapto (vlax-make-safearray vlax-vbdouble (quote (0 . 1)))
        )
        (vlax-safearray-fill vlapto (polar ptn ang dis))
        (vla-put-coordinate ent2 n vlapto)
       )
      )
      (grdraw point ptold 0)
     )
    )
   )
  )
)
(setvar "orthomode" oor)
(setvar "osmode" oos)
(setvar "cmdecho" 1)
(princ)
)

yoyoho

谢谢! wudechao 分享程序!!!!

paulpipi

要是能输入距离就好了

x_s_s_1

有bug，不能选了线再选PL，或选了PL再选线，待高手

2. ;不封闭的多义线动态拉伸dyst
   
3. (defun c:dyst ( / old_cmd +- ang ang0 dis
   
4.        e       ent      epar gpt  gpt1
   
5.        grr      i        ind mpar  n
   
6.        o par pt  pt1
   
7.        pt2      ptn      pto spar
   
8.        vlapto   ss       tpar
   
9.        times
   
10.       )
    
11. ;;;  (mini_start nil)
    
12. ;;;  (princ "\n不封闭的多义线动态拉伸 carrot1983 2008/11/25")
    
13.   (setq en (entsel))
    
14.   (if (= "LINE" (cdr (assoc 0 (entget (car en)))))
    
15.     (COMMAND "LENGTHEN" "DY" en)
    
16.   (if (and (setq pt en)
    
17.         (setq e (car pt)
    
18.               pt (cadr pt)
    
19.               o (vlax-ename->vla-object e)
    
20.      )
    
21.         (= (vlax-get-property o 'ObjectName) "AcDbPolyline")
    
22.         (not (vlax-curve-isclosed o))
    
23.       )
    
24.     (progn
    
25.       (setq pt (vlax-curve-getClosestPointTo o (trans pt 1 0))
    
26.          spar (vlax-curve-getstartparam e)
    
27.             epar (vlax-curve-getendparam e)
    
28.             tpar (- epar spar)
    
29.             par (vlax-curve-getparamatpoint o pt)
    
30.       ang0 (vlax-curve-getfirstderiv o par)
    
31.       ang0 (angle '(0 0) (list (car ang0) (cadr ang0)))
    
32.             ind (fix par)
    
33.             mpar (+ ind 0.5)
    
34.    )
    
35.       (while (and (setq grr (grread t 4 0))
    
36.             (member (car grr) (list 2 5 25))
    
37.           )
    
38.           (setq pt1 (vlax-curve-getpointatparam e ind)
    
39.                 pt2 (vlax-curve-getpointatparam e (+ ind 1))
    
40.        )
    
41.           (if (< par mpar)
    
42.               (setq i 0 +- - times (+ ind 1))
    
43.               (setq i pt1 pt1 pt2 pt2 i i 1 +- + times (fix (- tpar ind)))
    
44.           )
    
45.           (setq gpt (cadr grr)
    
46.                 gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
    
47.                 pto (inters pt1 pt2 gpt gpt1 nil)
    
48.                 dis (distance pt1 pto)
    
49.                 ang (angle pt1 pto)
    
50.        )
    
51.           (repeat times
    
52.           (setq n (+- ind i)
    
53.                 i (1+ i)
    
54.        ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate o n)))
    
55.                 vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))
    
56.           )
    
57.           (vlax-safearray-fill vlapto (polar ptn ang dis))
    
58.           (vla-put-coordinate o n vlapto)
    
59.          )
    
60.       )
    
61.     )
    
62.   ))
    
63. ;;;  (mai_end)
    
64. )
    
65. 
    

;不封闭的多义线动态拉伸dyst<br /> (defun c:dyst ( / old_cmd +- ang ang0 dis<br />        e       ent      epar gpt  gpt1<br />        grr      i        ind mpar  n<br />        o par pt  pt1<br />        pt2      ptn      pto spar<br />        vlapto   ss       tpar<br />        times<br />       )<br /> ;;;  (mini_start nil)<br /> ;;;  (princ "\n不封闭的多义线动态拉伸 carrot1983 2008/11/25")<br />   (setq en (entsel))<br />   (if (= "LINE" (cdr (assoc 0 (entget (car en)))))<br />     (COMMAND "LENGTHEN" "DY" en)<br />   (if (and (setq pt en)<br />         (setq e (car pt)<br />               pt (cadr pt)<br />               o (vlax-ename->vla-object e)<br />      )<br />         (= (vlax-get-property o 'ObjectName) "AcDbPolyline")<br />         (not (vlax-curve-isclosed o))<br />       )<br />     (progn<br />       (setq pt (vlax-curve-getClosestPointTo o (trans pt 1 0))<br />          spar (vlax-curve-getstartparam e)<br />             epar (vlax-curve-getendparam e)<br />             tpar (- epar spar)<br />             par (vlax-curve-getparamatpoint o pt)<br />       ang0 (vlax-curve-getfirstderiv o par)<br />       ang0 (angle '(0 0) (list (car ang0) (cadr ang0)))<br />             ind (fix par)<br />             mpar (+ ind 0.5)<br />    )<br />       (while (and (setq grr (grread t 4 0))<br />             (member (car grr) (list 2 5 25))<br />           )<br />           (setq pt1 (vlax-curve-getpointatparam e ind)<br />                 pt2 (vlax-curve-getpointatparam e (+ ind 1))<br />        )<br />           (if (< par mpar)<br />               (setq i 0 +- - times (+ ind 1))<br />               (setq i pt1 pt1 pt2 pt2 i i 1 +- + times (fix (- tpar ind)))<br />           )<br />           (setq gpt (cadr grr)<br />                 gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))<br />                 pto (inters pt1 pt2 gpt gpt1 nil)<br />                 dis (distance pt1 pto)<br />                 ang (angle pt1 pto)<br />        )<br />           (repeat times<br />           (setq n (+- ind i)<br />                 i (1+ i)<br />        ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate o n)))<br />                 vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))<br />           )<br />           (vlax-safearray-fill vlapto (polar ptn ang dis))<br />           (vla-put-coordinate o n vlapto)<br />          )<br />       )<br />     )<br />   ))<br /> ;;;  (mai_end)<br /> )<br /> <br />

x_s_s_1

preone

好东西 真不少~~

xsso

不错啊，但是不好控制，还需要优化一下

半听可乐

两个程序都很实用，要是能合并就更完美了！

半听可乐

半听可乐 发表于 2012-8-6 07:39
两个程序都很实用，要是能合并就更完美了！

谢谢你，正如你所说，还有点小瑕疵嘛

qyming

wudechao 发表于 2013-12-9 01:07
;完美版本,经过长时间修改完善,支持直线,圆弧,椭圆弧,多义线,并在ucs座标系下也可以运行.
(defun c:dyst ( ...

好程序，动态拉伸

清风明月名字

谢谢8楼楼主的分享！运行效果良好，收藏备用。