线动态拉伸（通杀line和pline,arc,ellipse,支持ucs座标系）LC
本帖最后由 wudechao 于 2013-12-9 00:59 编辑(defun c:lc (/ *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)
)
CAD的直线动态延伸不能延伸多义线,非常不爽.以上代码是本人根据论坛上的源代码修改的,已经非常完善了,看哪位高手能把它精简的更完善一点. 不能捕捉的！ 1,对于直线拉伸，起点会变，算是bug，当把拉伸点靠近起点的时候，起点就变成了拉伸点。
2,不支持闭合多段线。
已经修改直线拉伸的bug.更新了源代码. 程序还有待完善啊，确实不支持捕捉 本帖最后由 wudechao 于 2013-10-27 13:59 编辑
直线动态延伸这个命令就是个粗略拉长直线的命令,我在结构画图中就是拉伸集中标注线,引线,楼板钢筋的工具,没有捕捉的必要.很完善了.用来代替CAD的 (command "lengthen" "dy")的命令. 尽管不算很完美，确实应该说是很不错。 用起来有点卡顿！希望斑竹能够改进些！ 感觉很好，比 "lengthen" "dy"命令强多了
页:
[1]
2