lisp绘制棱锥_动态绘制示坡线 - AutoLISP/Visual LISP 编程技术 - CAD论坛 - 明经CAD社区 - Powered by Discuz!...

本帖最后由 20060510412 于 2018-11-4 22:11 编辑

[code="lisp]

;;

;;动态示坡线   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 [d]间距增加0.05倍 / [s]间距减小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-getDistAtParam  oba 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 0  en '()

end (vlax-curve-getEndParam obs)  ;;端点参数

SumL (vlax-curve-getDistAtParam  obs end)) ;;曲线总长

(while (progn

(setq Lpa (vlax-curve-getParamAtDist obs (* n d)) ;;指定距离的参数

La (vlax-curve-getDistAtParam  obs 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)[/code]http://bbs.mjtd.com/forum.php?mo ... %C6%C2%CF%DF&page=1

这个网页上有关于动态示坡线的源码，感觉很不错，只不过一般情况下，示坡线都是一长一短的线型，经过自己修改，已经可以实现自己想要的效果了，在这里先谢谢原作者了。

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有帐号？注册

x