【源码分享】动态绘制示坡线

20060510412 · 发表于 2018-10-31 17:04

本帖最后由 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 [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)

;; 
;;动态示坡线   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)

http://bbs.mjtd.com/forum.php?mo ... %C6%C2%CF%DF&page=1
这个网页上有关于动态示坡线的源码，感觉很不错，只不过一般情况下，示坡线都是一长一短的线型，经过自己修改，已经可以实现自己想要的效果了，在这里先谢谢原作者了。

20060510412 · 发表于 2018-10-31 19:20

不好意思，不知道怎么做gif动画演示

panliang9 · 发表于 2018-11-1 08:36

本帖最后由 panliang9 于 2018-11-1 08:38 编辑

非常好，用起来超级爽！

20060510412 · 发表于 2018-11-1 08:51

又修改了一下，主要是对于过长的曲线，还是用默认1.4的间隔，调整起来太麻烦了。我修改为默认将曲线分为25份，然后d增加0.05倍间距，s减小0.05倍间距。
同时，在生成示坡线之后，删除那两行长度与间距的文本

dhcad · 发表于 2019-1-17 09:13

真棒，很实用

yoyoho · 发表于 2019-1-17 22:45

非常好，很实用，谢谢分享!!!!!

decemc · 发表于 2020-2-26 13:18

感谢感谢，非常好用

完整武器 · 发表于 2020-3-20 19:41

很好用，谢谢！！

lzg8877 · 发表于 2020-3-20 23:31

感谢感谢，非常好用

tony1435 · 发表于 2020-7-2 19:19

这个厉害，感谢楼主~

账号		自动登录	找回密码
密码			注册

[提问] 【源码分享】动态绘制示坡线

本帖子中包含更多资源

评分