斜坡线绘制

lucas_3333

看见有人求画斜坡线的， 非此专业，不懂，但记得曾经收集过此类程序
因为分享出来，仅此而已，不懂勿问，不喜勿喷。

1. (defun C:SLOPE-LINE (/ Talud_boven  Talud_onder afstand afstand_totaal count p1 p2 kleur)
   
2. 
   
3.   (defun IS-ON-PL? (ENAME PKT /)
   
4.     (vl-catch-all-apply
   
5.       'vlax-curve-getdistatpoint
   
6.       (list
   
7.         ENAME
   
8.         PKT
   
9.         ) ;_ end of list
   
10.       ) ;_ end of vlax-curve-getDistAtPoint
    
11.     PKT
    
12.     ) ;_ end defun
    
13. 
    
14. (vl-load-com)
    
15. 
    
16. 
    
17.   (if (and (setq Talud_boven (car (entsel "\nSelect Top slope: ")))
    
18.            (setq Talud_onder (car (entsel "\nSelect Bottom slope: ")))
    
19.            (setq afstand (getint "\nLine slope distance:"))
    
20.            (setq kleur (acad_colordlg 8))
    
21.            ) ;_ end of and
    
22.    
    
23.     (progn
    
24.       (setq afstand_totaal 0)
    
25.       (setq count 0)
    
26.       (setq p1 (vlax-curve-getStartPoint
    
27.                  (vlax-ename->vla-object Talud_boven)
    
28.                  ) ;_ end of vlax-curve-getStartPoint
    
29.             ) ;_ end of setq
    
30.       (while p1
    
31.         (if (equal (/ count 2.0) (fix (/ count 2.0)) 0.001)
    
32.           (setq p2
    
33.                  (vlax-curve-getClosestPointTo
    
34.                    (vlax-ename->vla-object Talud_onder)
    
35.                    p1
    
36.                    ) ;_ end of vlax-curve-getClosestPointTo
    
37.                 ) ;_ end of setq
    
38.           (setq
    
39.             p2 (MAPCAR '(LAMBDA (x) (/ x 2))
    
40.                        (MAPCAR '+
    
41.                                p1
    
42.                                (vlax-curve-getClosestPointTo
    
43.                                  (vlax-ename->vla-object Talud_onder)
    
44.                                  p1
    
45.                                  ) ;_ end of vlax-curve-getClosestPointTo
    
46.                                ) ;_ end of MAPCAR
    
47.                        ) ;_ end of MAPCAR
    
48.             ) ;_ end of setq
    
49.           ) ;_ end of if
    
50.         (entmake
    
51.           (list '(0 . "LINE")
    
52.                 (cons 10 p1)
    
53.                 (cons 11 p2)
    
54.                 ;'(62 . 1) ; standaard kleur
    
55.                 (cons 62 kleur) ; kleur dia dialog instellen
    
56. 
    
57.           ) ;_ end of list
    
58.         ) ;_ end of entmake
    
59.         (if
    
60.           (setq p1 (IS-ON-PL?
    
61.                      (vlax-ename->vla-object Talud_boven)
    
62.                      (vlax-curve-getpointatdist
    
63.                        (vlax-ename->vla-object Talud_boven)
    
64.                        (setq afstand_totaal (+ afstand_totaal afstand))
    
65.                        ) ;_ end of vlax-curve-getpointatdist
    
66.                      ) ;_ end of IS-ON-PL?
    
67.                 ) ;_ end of setq
    
68.            p1
    
69.            ) ;_ end of if
    
70.         (setq count (1+ count))
    
71.         ) ;_ end of while
    
72.       ) ;_ end of progn
    
73.     ) ;_ end of if
    
74.   ) ;_ end of defun
    

(defun C:SLOPE-LINE (/ Talud_boven  Talud_onder afstand afstand_totaal count p1 p2 kleur)<br /> <br />   (defun IS-ON-PL? (ENAME PKT /)<br />     (vl-catch-all-apply<br />       'vlax-curve-getdistatpoint<br />       (list<br />         ENAME<br />         PKT<br />         ) ;_ end of list<br />       ) ;_ end of vlax-curve-getDistAtPoint<br />     PKT<br />     ) ;_ end defun<br /> <br /> (vl-load-com)<br /> <br /> <br />   (if (and (setq Talud_boven (car (entsel "\nSelect Top slope: ")))<br />            (setq Talud_onder (car (entsel "\nSelect Bottom slope: ")))<br />            (setq afstand (getint "\nLine slope distance:"))<br />            (setq kleur (acad_colordlg 8))<br />            ) ;_ end of and<br />     <br />     (progn<br />       (setq afstand_totaal 0)<br />       (setq count 0)<br />       (setq p1 (vlax-curve-getStartPoint<br />                  (vlax-ename->vla-object Talud_boven)<br />                  ) ;_ end of vlax-curve-getStartPoint<br />             ) ;_ end of setq<br />       (while p1<br />         (if (equal (/ count 2.0) (fix (/ count 2.0)) 0.001)<br />           (setq p2<br />                  (vlax-curve-getClosestPointTo<br />                    (vlax-ename->vla-object Talud_onder)<br />                    p1<br />                    ) ;_ end of vlax-curve-getClosestPointTo<br />                 ) ;_ end of setq<br />           (setq<br />             p2 (MAPCAR '(LAMBDA (x) (/ x 2))<br />                        (MAPCAR '+<br />                                p1<br />                                (vlax-curve-getClosestPointTo<br />                                  (vlax-ename->vla-object Talud_onder)<br />                                  p1<br />                                  ) ;_ end of vlax-curve-getClosestPointTo<br />                                ) ;_ end of MAPCAR<br />                        ) ;_ end of MAPCAR<br />             ) ;_ end of setq<br />           ) ;_ end of if<br />         (entmake<br />           (list '(0 . "LINE")<br />                 (cons 10 p1)<br />                 (cons 11 p2)<br />                 ;'(62 . 1) ; standaard kleur<br />                 (cons 62 kleur) ; kleur dia dialog instellen<br /> <br />           ) ;_ end of list<br />         ) ;_ end of entmake<br />         (if<br />           (setq p1 (IS-ON-PL?<br />                      (vlax-ename->vla-object Talud_boven)<br />                      (vlax-curve-getpointatdist<br />                        (vlax-ename->vla-object Talud_boven)<br />                        (setq afstand_totaal (+ afstand_totaal afstand))<br />                        ) ;_ end of vlax-curve-getpointatdist<br />                      ) ;_ end of IS-ON-PL?<br />                 ) ;_ end of setq<br />            p1<br />            ) ;_ end of if<br />         (setq count (1+ count))<br />         ) ;_ end of while<br />       ) ;_ end of progn<br />     ) ;_ end of if<br />   ) ;_ end of defun<br />

zhenz02

学习学习！多谢楼主！！

jsh2939

看似很神奇

yoyoho

感谢 lucas_3333 分享程序!

lucas_3333

yoyoho 发表于 2015-5-16 10:29
感谢 lucas_3333 分享程序!

只要有源码的地方就有你的身影，不论是哪行哪业
你是专业收集源码的吗？
为何不分享一些出来？ 箱子沉了，背着累！

360527010

好东西哦,回复学习学习

hao3ren

这个是示坡线

qyming

斜坡线绘制....

emk

好像见过，感谢 lucas_3333 分享

xiang19751218

谢谢分享程序。