【源码分享】动态绘制示坡线
本帖最后由 20060510412 于 2022-3-7 21:55 编辑;;
;;动态示坡线 by 明经通道QQ9034598小蜜蜂2013-5-22
;;
(defun c:swx( / ss n m jdp jdp2 sntt txt1 txt2 xpj pt cg pl hh ssList end1 SumL1)
(setvar "DIMZIN" 1)
(setq ss (car (entsel "\n请选择曲线边界:")))
(if (and ss (vl-position (dxf 0 (entget ss))
'("POLYLINE" "LINE" "LWPOLYLINE" "CIRCLE" "ARC" "SPLINE" "ELLIPSE")))
(progn
(setq Jdp (getpoint "\n 间距增加0.05倍 / 间距减小0.05倍 / 长度及方向 <给点>:"))
(if jdp (progn
(setq hh (/ (getvar "VIEWSIZE") 25)
Jdp1 (polar jdp (* 0.25 pi) (* 0.2 hh))
Jdp2 (polar jdp1 (* 0.5 pi) (* 1.2 hh))
oba (vlax-ename->vla-object ss)
end1 (vlax-curve-getEndParam oba);;端点参数
SumL1 (vlax-curve-getDistAtParamoba end1) ;;曲线总长
dis (/ SumL1 25)
sntt (treaSline oba dis)
txt1 (cretxt (strcat "间距: " (rtos dis 2 3)) jdp2)
txt2 (cretxt (strcat "长度: " (rtos 5 2 3)) jdp1))
(creL jdp jdp)(setq xpj (entlast) pt jdp)
(while (or (= (car (setq mouse (grread t 5 0))) 5)(= (car mouse) 2))
(setq pt (if (= (car mouse) 2) pt (cadr mouse))
n 0
cg (cos (angle jdp pt));;橡皮筋线的角度余弦
PL (* (distance pt Jdp)(if (> cg 0) 1 -1)))
(entmod (subst (cons 11 pt)(assoc 11 (entget xpj))(entget xpj)))
(if (and (= (car mouse) 2) (or (= (cadr mouse) 100)(= (cadr mouse) 115)))
(progn
(mapcar '(lambda(x)(entdel (car x))) sntt)
(if (= (cadr mouse) 100)(setq dis (+ (* 0.05 dis) dis)))
(if (= (cadr mouse) 115)(setq dis (- dis (* 0.05 dis))))
(setq sntt (treaSline oba dis)))
) ;;增加或减小间距
(modentxt txt1 txt2 dis (abs pl) pt)
(setq n 0)
(repeat (length sntt)
(if (= 1 (rem n 2)) (modent (nth n sntt) pl) (modent (nth n sntt) (/ pl 2)))
(setq n (1+ n))
)
)(entdel xpj) (entdel txt1) (entdel txt2)
))))
(setvar "DIMZIN" 0)
(princ)
)
;;刷新文本
(defun modentxt(ent1 ent2 d L pt0 / t1 t2 pt1 pt2 h en1 en2)
(setq en1 (entget ent1)
en2 (entget ent2)
h (/ (getvar "VIEWSIZE") 25)
pt1 (polar pt0 (* 0.25 pi) (* 0.2 h))
t1 (subst (cons 1 (strcat "间距: " (rtos d 2 3 )))(assoc 1 en1)en1)
t1 (subst (cons 10 pt1)(assoc 10 t1)t1)
t1 (subst (cons 40 h)(assoc 40 t1)t1)
t2 (subst (cons 1 (strcat "长度: " (rtos L 2 3)))(assoc 1 en2)en2)
pt2 (polar pt1 (* 0.5 pi) (* 1.2 h))
t2 (subst (cons 10 pt2)(assoc 10 t2)t2)
t2 (subst (cons 40 h)(assoc 40 t2)t2))
(entmod t1) (entmod t2)
)
;;刷新直线线
(defun modent(en L / ent mp)
(setq ent (entget (car en))
mp (polar (dxf 10 ent) (cadr en) L))
(entmod (subst (cons 11 mp)(assoc 11 ent) ent))
)
;;曲线处理
(defun treaSline(obs d / n en end SumL Lpa La ds AG sy Lxy)
(setq n 0en '()
end (vlax-curve-getEndParam obs);;端点参数
SumL (vlax-curve-getDistAtParamobs end)) ;;曲线总长
(while (progn
(setq Lpa (vlax-curve-getParamAtDist obs (* n d)) ;;指定距离的参数
La (vlax-curve-getDistAtParamobs Lpa) ;;开始到指定点长度
Ds (vlax-curve-getFirstDeriv obs Lpa) ;;一阶导数，切线
Ag (+ (atan (cadr ds)(car ds)) (* 0.5 pi));;斜角
Sy (- SumL La);;剩余长度
Lxy (vlax-curve-getPointAtDist obs (* n d))) ;;指定长度的坐标
(creL Lxy Lxy)
(setq en (cons (list (entlast) Ag) en) n (+ n 1))
(> Sy d))
) en
)
;;画单线
(defun creL(p1 p2)(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))))
;;写字
(defun cretxt(txt pt)
(entmake (list '(0 . "TEXT") (cons 1 txt) (cons 7 (getvar "TEXTSTYLE"))
(cons 10 pt) '(41 . 0.76) (cons 40 (/ (getvar "VIEWSIZE") 25))))(entlast)
)
;;dxf码
(defun dxf(n ent) (cdr (assoc n ent)))
(princ)http://bbs.mjtd.com/forum.php?mo ... %C6%C2%CF%DF&page=1
这个网页上有关于动态示坡线的源码，感觉很不错，只不过一般情况下，示坡线都是一长一短的线型，经过自己修改，已经可以实现自己想要的效果了，在这里先谢谢原作者了。
[*]
不好意思，不知道怎么做gif动画演示 本帖最后由 panliang9 于 2018-11-1 08:38 编辑
非常好，用起来超级爽！ 又修改了一下，主要是对于过长的曲线，还是用默认1.4的间隔，调整起来太麻烦了。我修改为默认将曲线分为25份，然后d增加0.05倍间距，s减小0.05倍间距。
同时，在生成示坡线之后，删除那两行长度与间距的文本 真棒，很实用 非常好，很实用，谢谢分享!!!!! 感谢感谢，非常好用 很好用，谢谢！！ 感谢感谢，非常好用 这个厉害，感谢楼主~
页:
[1]