直线动态延伸这个命令就是个粗略拉长直线的命令,我在结构画图中就是拉伸集中标注线,引线,楼板钢筋的工具,没 ...
代替(command "lengthen" "dy")的命令，还不包括圆弧哦 再次更新,支持圆弧,椭圆弧. 怎样使用？ 支持楼主！谢谢 看起来挺不错，但好像用处不大啊，平直的先夹点不就行的了，斜向的很少遇到 本帖最后由 xiaolong1487 于 2015-12-25 23:24 编辑
我的 quote会出错 ，拉伸中误按键盘会出错！
改了下;线动态拉伸（通杀line和pline,arc,ellipse,支持ucs座标系）
(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)
(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选择要修改的对象:"))
(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 (and (setq n (grread t 4 3)) (= (car n) 5))
(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 (and (setq n (grread t 4 3)) (= (car n) 5))
(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 '(0 0) maj)
b (* a rat)
angle0 (angle '(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 (and (setq n (grread t 4 3)) (= (car n) 5))
(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 '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 '(0 0) (list (car ang0) (cadr ang0)))
ind (fix par)
mpar (+ ind 0.5)
)
(while (and (setq grr (grread t 4 3)) (= (car grr) 5))
(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 '(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)
)
页:
1
[2]