线动态拉伸（通杀line和pline,arc,ellipse,支持ucs座标系）LC

ucuc2003

wudechao 发表于 2013-10-31 08:52
直线动态延伸这个命令就是个粗略拉长直线的命令,我在结构画图中就是拉伸集中标注线,引线,楼板钢筋的工具,没 ...

代替(command "lengthen" "dy")的命令，还不包括圆弧哦

wudechao

再次更新,支持圆弧,椭圆弧.

chang1622

怎样使用？

lucas_3333

支持楼主！谢谢

zheng209

看起来挺不错，但好像用处不大啊，平直的先夹点不就行的了，斜向的很少遇到

xiaolong1487

我的 quote会出错 ，拉伸中误按键盘会出错！
改了下

2. ;线动态拉伸（通杀line和pline,arc,ellipse,支持ucs座标系）
   
3. (defun c:ts3 (/ *error* +- a ang ang0 angle0 angle1 angle2 angle3 b cen dis dis1 dis2 dxf e en ent ent2 epar gpt gpt1 grr i ind maj mpar n oor oos p1 p2 par per-pt point pt pt0 pt1 pt2 ptmid ptn ptold r1 r2 rad rat spar times tpar vlapto)
   
4.   (vl-load-com)
   
5.   (setvar "cmdecho" 0)
   
6.   (defun *error* (msg)
   
7.     (if oos
   
8.       (setvar "osmode" oos)
   
9.     )
   
10.     (if oor
    
11.       (setvar "orthomode" oor)
    
12.     )
    
13.   )
    
14.   (setq oor (getvar "orthomode")
    
15.     oos (getvar "osmode")
    
16.   )
    
17.   (setvar "orthomode" 0)
    
18.   (setvar "osmode" 0)
    
19.   (while (setq en (entsel "\n选择要修改的对象:"))
    
20.     (if (= "LINE" (cdr (assoc 0 (entget (car en)))))
    
21.       (progn
    
22.         (prompt (strcat "\n指定新端点:"))
    
23.         (setq point (osnap (cadr en) "nea"))
    
24.         (setq ent (car en))
    
25.         (setq dxf (entget ent))
    
26.         (setq p1 (cdr (assoc 10 dxf))
    
27.           p1 (trans p1 0 1)
    
28.           p2 (cdr (assoc 11 dxf))
    
29.           p2 (trans p2 0 1)
    
30.         )
    
31.         (setq dis1 (distance p1 point)
    
32.           dis2 (distance p2 point)
    
33.         )
    
34.         (while (and (setq n (grread t 4 3)) (= (car n) 5))
    
35.           (setq pt (cadr n))
    
36.           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
    
37.           (setq per-pt (trans per-pt 1 0))
    
38.           (if ptold
    
39.             (grdraw point ptold 0)
    
40.           )
    
41.           (grdraw point pt 7)
    
42.           (setq ptold pt)
    
43.           (if (>= dis1 dis2)
    
44.             (progn
    
45.               (setq dxf (subst
    
46.                           (cons 11 per-pt)
    
47.                           (assoc 11 dxf)
    
48.                           dxf
    
49.                         )
    
50.               )
    
51.             )
    
52.             (progn
    
53.               (setq dxf (subst
    
54.                           (cons 10 per-pt)
    
55.                           (assoc 10 dxf)
    
56.                           dxf
    
57.                         )
    
58.               )
    
59.             )
    
60.           )
    
61.           (entmod dxf)
    
62.         )
    
63.         (grdraw point ptold 0)
    
64.       )
    
65.     )
    
66.     (if (= "ARC" (cdr (assoc 0 (entget (car en)))))
    
67.       (progn
    
68.         (prompt (strcat "\n指定新端点:"))
    
69.         (setq point (osnap (cadr en) "nea"))
    
70.         (setq ent (car en))
    
71.         (setq dxf (entget ent))
    
72.         (setq cen (cdr (assoc 10 dxf))
    
73.           rad (cdr (assoc 40 dxf))
    
74.           angle1 (cdr (assoc 50 dxf))
    
75.           angle2 (cdr (assoc 51 dxf))
    
76.           p1 (polar cen angle1 rad)
    
77.           p1 (trans p1 0 1)
    
78.           p2 (polar cen angle2 rad)
    
79.           p2 (trans p2 0 1)
    
80.           dis1 (distance p1 point)
    
81.           dis2 (distance p2 point)
    
82.         )
    
83.         (while (and (setq n (grread t 4 3)) (= (car n) 5))
    
84.           (setq pt (cadr n))
    
85.           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
    
86.           (setq per-pt (trans per-pt 1 0))
    
87.           (setq per-pt (angle cen per-pt))
    
88.           (if ptold
    
89.             (grdraw point ptold 0)
    
90.           )
    
91.           (grdraw point pt 7)
    
92.           (setq ptold pt)
    
93.           (if (>= dis1 dis2)
    
94.             (progn
    
95.               (setq dxf (subst
    
96.                           (cons 51 per-pt)
    
97.                           (assoc 51 dxf)
    
98.                           dxf
    
99.                         )
    
100.               )
     
101.             )
     
102.             (progn
     
103.               (setq dxf (subst
     
104.                           (cons 50 per-pt)
     
105.                           (assoc 50 dxf)
     
106.                           dxf
     
107.                         )
     
108.               )
     
109.             )
     
110.           )
     
111.           (entmod dxf)
     
112.         )
     
113.         (grdraw point ptold 0)
     
114.       )
     
115.     )
     
116.     (if (= "ELLIPSE" (cdr (assoc 0 (entget (car en)))))
     
117.       (progn
     
118.         (prompt (strcat "\n指定新端点:"))
     
119.         (setq point (osnap (cadr en) "nea"))
     
120.         (setq ent (car en))
     
121.         (setq dxf (entget ent))
     
122.         (setq cen (cdr (assoc 10 dxf))
     
123.           maj (cdr (assoc 11 dxf))
     
124.           rat (cdr (assoc 40 dxf))
     
125.           a (distance '(0 0) maj)
     
126.           b (* a rat)
     
127.           angle0 (angle '(0 0) maj)
     
128.           angle1 (cdr (assoc 41 dxf))
     
129.           angle2 (cdr (assoc 42 dxf))
     
130.         )
     
131.         (setq r1 (/ (* a b) (sqrt (+ (expt (* b (cos angle1)) 2) (expt (* a (sin angle1)) 2)))))
     
132.         (setq r2 (/ (* a b) (sqrt (+ (expt (* b (cos angle2)) 2) (expt (* a (sin angle2)) 2)))))
     
133.         (setq angle1 (+ angle1 angle0)
     
134.           angle2 (+ angle2 angle0)
     
135.           point (trans point 1 0)
     
136.           dis1 (distance (polar cen angle1 r1) point)
     
137.           dis2 (distance (polar cen angle2 r2) point)
     
138.           point (trans point 0 1)
     
139.         )
     
140.         (while (and (setq n (grread t 4 3)) (= (car n) 5))
     
141.           (setq pt (cadr n))
     
142.           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))
     
143.           (setq per-pt (trans per-pt 1 0)
     
144.             angle3 (angle cen per-pt)
     
145.           )
     
146.           (if (< angle3 angle1)
     
147.             (setq angle3 (+ angle3 (* 2 pi)))
     
148.           )
     
149.           (setq per-pt (- angle3 angle0))
     
150.           (if ptold
     
151.             (grdraw point ptold 0)
     
152.           )
     
153.           (grdraw point pt 7)
     
154.           (setq ptold pt)
     
155.           (if (>= dis1 dis2)
     
156.             (progn
     
157.               (setq dxf (subst
     
158.                           (cons 42 per-pt)
     
159.                           (assoc 42 dxf)
     
160.                           dxf
     
161.                         )
     
162.               )
     
163.             )
     
164.             (progn
     
165.               (setq dxf (subst
     
166.                           (cons 41 per-pt)
     
167.                           (assoc 41 dxf)
     
168.                           dxf
     
169.                         )
     
170.               )
     
171.             )
     
172.           )
     
173.           (entmod dxf)
     
174.         )
     
175.         (grdraw point ptold 0)
     
176.       )
     
177.     )
     
178.     (if (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))
     
179.       (progn
     
180.         (prompt (strcat "\n指定新端点:"))
     
181.         (setq point (osnap (cadr en) "nea"))
     
182.         (setq pt en)
     
183.         (setq e (car pt)
     
184.           pt0 (cadr pt)
     
185.           ent2 (vlax-ename->vla-object e)
     
186.         )
     
187.         (if (and
     
188.               (= (vlax-get-property ent2 'objectname) "AcDbPolyline")
     
189.               (not (vlax-curve-isclosed ent2))
     
190.             )
     
191.           (progn
     
192.             (setq pt0 (vlax-curve-getclosestpointto ent2 (trans pt0 1 0))
     
193.               spar (vlax-curve-getstartparam e)
     
194.               epar (vlax-curve-getendparam e)
     
195.               tpar (- epar spar)
     
196.               par (vlax-curve-getparamatpoint ent2 pt0)
     
197.               ang0 (vlax-curve-getfirstderiv ent2 par)
     
198.               ang0 (angle '(0 0) (list (car ang0) (cadr ang0)))
     
199.               ind (fix par)
     
200.               mpar (+ ind 0.5)
     
201.             )
     
202.             (while (and (setq grr (grread t 4 3)) (= (car grr) 5))
     
203.               (setq pt1 (vlax-curve-getpointatparam e ind)
     
204.                 pt2 (vlax-curve-getpointatparam e (+ ind 1))
     
205.               )
     
206.               (if (< par mpar)
     
207.                 (setq i 0
     
208.                   +- -
     
209.                   times (+ ind 1)
     
210.                 )
     
211.                 (setq i pt1
     
212.                   pt1 pt2
     
213.                   pt2 i
     
214.                   i 1
     
215.                   +- +
     
216.                   times (fix (- tpar ind))
     
217.                 )
     
218.               )
     
219.               (setq gpt (cadr grr)
     
220.                 gpt (trans gpt 1 0)
     
221.                 gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))
     
222.                 ptmid (inters
     
223.                         pt1
     
224.                         pt2
     
225.                         gpt
     
226.                         gpt1
     
227.                         nil
     
228.                       )
     
229.                 dis (distance pt1 ptmid)
     
230.                 ang (angle pt1 ptmid)
     
231.               )
     
232.               (setq gpt (trans gpt 0 1))
     
233.               (if ptold
     
234.                 (grdraw point ptold 0)
     
235.               )
     
236.               (grdraw point gpt 7)
     
237.               (setq ptold gpt)
     
238.               (repeat times
     
239.                 (setq n (+- ind i)
     
240.                   i (1+ i)
     
241.                   ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate ent2 n)))
     
242.                   vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))
     
243.                 )
     
244.                 (vlax-safearray-fill vlapto (polar ptn ang dis))
     
245.                 (vla-put-coordinate ent2 n vlapto)
     
246.               )
     
247.             )
     
248.             (grdraw point ptold 0)
     
249.           )
     
250.         )
     
251.       )
     
252.     )
     
253.   )
     
254.   (setvar "orthomode" oor)
     
255.   (setvar "osmode" oos)
     
256.   (setvar "cmdecho" 1)
     
257.   (princ)
     
258. )

;线动态拉伸（通杀line和pline,arc,ellipse,支持ucs座标系）<br /> (defun c:ts3 (/ *error* +- a ang ang0 angle0 angle1 angle2 angle3 b cen dis dis1 dis2 dxf e en ent ent2 epar gpt gpt1 grr i ind maj mpar n oor oos p1 p2 par per-pt point pt pt0 pt1 pt2 ptmid ptn ptold r1 r2 rad rat spar times tpar vlapto)<br />   (vl-load-com)<br />   (setvar "cmdecho" 0)<br />   (defun *error* (msg)<br />     (if oos<br />       (setvar "osmode" oos)<br />     )<br />     (if oor<br />       (setvar "orthomode" oor)<br />     )<br />   )<br />   (setq oor (getvar "orthomode")<br />     oos (getvar "osmode")<br />   )<br />   (setvar "orthomode" 0)<br />   (setvar "osmode" 0)<br />   (while (setq en (entsel "\n选择要修改的对象:"))<br />     (if (= "LINE" (cdr (assoc 0 (entget (car en)))))<br />       (progn<br />         (prompt (strcat "\n指定新端点:"))<br />         (setq point (osnap (cadr en) "nea"))<br />         (setq ent (car en))<br />         (setq dxf (entget ent))<br />         (setq p1 (cdr (assoc 10 dxf))<br />           p1 (trans p1 0 1)<br />           p2 (cdr (assoc 11 dxf))<br />           p2 (trans p2 0 1)<br />         )<br />         (setq dis1 (distance p1 point)<br />           dis2 (distance p2 point)<br />         )<br />         (while (and (setq n (grread t 4 3)) (= (car n) 5))<br />           (setq pt (cadr n))<br />           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))<br />           (setq per-pt (trans per-pt 1 0))<br />           (if ptold<br />             (grdraw point ptold 0)<br />           )<br />           (grdraw point pt 7)<br />           (setq ptold pt)<br />           (if (>= dis1 dis2)<br />             (progn<br />               (setq dxf (subst<br />                           (cons 11 per-pt)<br />                           (assoc 11 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />             (progn<br />               (setq dxf (subst<br />                           (cons 10 per-pt)<br />                           (assoc 10 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />           )<br />           (entmod dxf)<br />         )<br />         (grdraw point ptold 0)<br />       )<br />     )<br />     (if (= "ARC" (cdr (assoc 0 (entget (car en)))))<br />       (progn<br />         (prompt (strcat "\n指定新端点:"))<br />         (setq point (osnap (cadr en) "nea"))<br />         (setq ent (car en))<br />         (setq dxf (entget ent))<br />         (setq cen (cdr (assoc 10 dxf))<br />           rad (cdr (assoc 40 dxf))<br />           angle1 (cdr (assoc 50 dxf))<br />           angle2 (cdr (assoc 51 dxf))<br />           p1 (polar cen angle1 rad)<br />           p1 (trans p1 0 1)<br />           p2 (polar cen angle2 rad)<br />           p2 (trans p2 0 1)<br />           dis1 (distance p1 point)<br />           dis2 (distance p2 point)<br />         )<br />         (while (and (setq n (grread t 4 3)) (= (car n) 5))<br />           (setq pt (cadr n))<br />           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))<br />           (setq per-pt (trans per-pt 1 0))<br />           (setq per-pt (angle cen per-pt))<br />           (if ptold<br />             (grdraw point ptold 0)<br />           )<br />           (grdraw point pt 7)<br />           (setq ptold pt)<br />           (if (>= dis1 dis2)<br />             (progn<br />               (setq dxf (subst<br />                           (cons 51 per-pt)<br />                           (assoc 51 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />             (progn<br />               (setq dxf (subst<br />                           (cons 50 per-pt)<br />                           (assoc 50 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />           )<br />           (entmod dxf)<br />         )<br />         (grdraw point ptold 0)<br />       )<br />     )<br />     (if (= "ELLIPSE" (cdr (assoc 0 (entget (car en)))))<br />       (progn<br />         (prompt (strcat "\n指定新端点:"))<br />         (setq point (osnap (cadr en) "nea"))<br />         (setq ent (car en))<br />         (setq dxf (entget ent))<br />         (setq cen (cdr (assoc 10 dxf))<br />           maj (cdr (assoc 11 dxf))<br />           rat (cdr (assoc 40 dxf))<br />           a (distance '(0 0) maj)<br />           b (* a rat)<br />           angle0 (angle '(0 0) maj)<br />           angle1 (cdr (assoc 41 dxf))<br />           angle2 (cdr (assoc 42 dxf))<br />         )<br />         (setq r1 (/ (* a b) (sqrt (+ (expt (* b (cos angle1)) 2) (expt (* a (sin angle1)) 2)))))<br />         (setq r2 (/ (* a b) (sqrt (+ (expt (* b (cos angle2)) 2) (expt (* a (sin angle2)) 2)))))<br />         (setq angle1 (+ angle1 angle0)<br />           angle2 (+ angle2 angle0)<br />           point (trans point 1 0)<br />           dis1 (distance (polar cen angle1 r1) point)<br />           dis2 (distance (polar cen angle2 r2) point)<br />           point (trans point 0 1)<br />         )<br />         (while (and (setq n (grread t 4 3)) (= (car n) 5))<br />           (setq pt (cadr n))<br />           (setq per-pt (trans (vlax-curve-getclosestpointto ent (trans pt 1 0) t) 0 1))<br />           (setq per-pt (trans per-pt 1 0)<br />             angle3 (angle cen per-pt)<br />           )<br />           (if (< angle3 angle1)<br />             (setq angle3 (+ angle3 (* 2 pi)))<br />           )<br />           (setq per-pt (- angle3 angle0))<br />           (if ptold<br />             (grdraw point ptold 0)<br />           )<br />           (grdraw point pt 7)<br />           (setq ptold pt)<br />           (if (>= dis1 dis2)<br />             (progn<br />               (setq dxf (subst<br />                           (cons 42 per-pt)<br />                           (assoc 42 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />             (progn<br />               (setq dxf (subst<br />                           (cons 41 per-pt)<br />                           (assoc 41 dxf)<br />                           dxf<br />                         )<br />               )<br />             )<br />           )<br />           (entmod dxf)<br />         )<br />         (grdraw point ptold 0)<br />       )<br />     )<br />     (if (= "LWPOLYLINE" (cdr (assoc 0 (entget (car en)))))<br />       (progn<br />         (prompt (strcat "\n指定新端点:"))<br />         (setq point (osnap (cadr en) "nea"))<br />         (setq pt en)<br />         (setq e (car pt)<br />           pt0 (cadr pt)<br />           ent2 (vlax-ename->vla-object e)<br />         )<br />         (if (and<br />               (= (vlax-get-property ent2 'objectname) "AcDbPolyline")<br />               (not (vlax-curve-isclosed ent2))<br />             )<br />           (progn<br />             (setq pt0 (vlax-curve-getclosestpointto ent2 (trans pt0 1 0))<br />               spar (vlax-curve-getstartparam e)<br />               epar (vlax-curve-getendparam e)<br />               tpar (- epar spar)<br />               par (vlax-curve-getparamatpoint ent2 pt0)<br />               ang0 (vlax-curve-getfirstderiv ent2 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 3)) (= (car grr) 5))<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<br />                   +- -<br />                   times (+ ind 1)<br />                 )<br />                 (setq i pt1<br />                   pt1 pt2<br />                   pt2 i<br />                   i 1<br />                   +- +<br />                   times (fix (- tpar ind))<br />                 )<br />               )<br />               (setq gpt (cadr grr)<br />                 gpt (trans gpt 1 0)<br />                 gpt1 (polar gpt (+ (* 0.5 pi) ang0) (car gpt))<br />                 ptmid (inters<br />                         pt1<br />                         pt2<br />                         gpt<br />                         gpt1<br />                         nil<br />                       )<br />                 dis (distance pt1 ptmid)<br />                 ang (angle pt1 ptmid)<br />               )<br />               (setq gpt (trans gpt 0 1))<br />               (if ptold<br />                 (grdraw point ptold 0)<br />               )<br />               (grdraw point gpt 7)<br />               (setq ptold gpt)<br />               (repeat times<br />                 (setq n (+- ind i)<br />                   i (1+ i)<br />                   ptn (vlax-safearray->list (vlax-variant-value (vla-get-coordinate ent2 n)))<br />                   vlapto (vlax-make-safearray vlax-vbdouble '(0 . 1))<br />                 )<br />                 (vlax-safearray-fill vlapto (polar ptn ang dis))<br />                 (vla-put-coordinate ent2 n vlapto)<br />               )<br />             )<br />             (grdraw point ptold 0)<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (setvar "orthomode" oor)<br />   (setvar "osmode" oos)<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )