沿曲线标注高程

树櫴希德

2. ;; 测量选定曲线上两点之间的距离
   
3. (defun apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)
   
4. ;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派工具箱,摄影  24942984
   
5.   
   
6.   
   
7. ;(setq ENOBJ (CAR (ENTSEL)))
   
8. ;(setq p1 (getpoint "\n选择曲线上的一点："))
   
9. ;(setq p2 (getpoint "\n选择曲线上的另一点："))
   
10. (setq dist1 (vlax-curve-getDistAtPoint enobj p1))
    
11. (setq dist2 (vlax-curve-getDistAtPoint enobj p2))
    
12. ;(print "\n测量段曲线长度：")
    
13. (setq dist (abs (- dist1 dist2)))
    
14. dist
    
15. )
    
16. 
    
17. (defun c:bg (  / ENOBJ p1 p2 s1 s2 p3  dist gcc bz dist1 xgc)
    
18. 
    
19. (setq ENOBJ (CAR (ENTSEL "\n请选择线段")))
    
20. (setq p1 (getpoint "\n选择曲线上的一点："))
    
21.   (setq s1 (getreal "\n请输入该点标高："))
    
22. (setq p2 (getpoint "\n选择曲线上的另一点："))
    
23. (setq s2 (getreal "\n请输入该点标高："))
    
24.   (setq dist (apkl ENOBJ p1 p2 ))
    
25. (setq gcc (- s1 s2))
    
26.   (setq bz (/ gcc dist))
    
27.   (while (setq p3 (getpoint "\n选择曲线上要查询的一点："))
    
28.     (setq dist1 (apkl ENOBJ p3 p2 ) )
    
29. (setq xgc (+ s2 (* dist1 bz )))
    
30.     (entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
    
31.    )
    
32. (princ)
    
33.       )
    

;; 测量选定曲线上两点之间的距离<br /> (defun apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)<br /> ;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>箱,摄影  24942984<br />   <br />   <br /> ;(setq ENOBJ (CAR (ENTSEL)))<br /> ;(setq p1 (getpoint "\n选择曲线上的一点："))<br /> ;(setq p2 (getpoint "\n选择曲线上的另一点："))<br /> (setq dist1 (vlax-curve-getDistAtPoint enobj p1))<br /> (setq dist2 (vlax-curve-getDistAtPoint enobj p2))<br /> ;(print "\n测量段曲线长度：")<br /> (setq dist (abs (- dist1 dist2)))<br /> dist<br /> )<br /> <br /> (defun c:bg (  / ENOBJ p1 p2 s1 s2 p3  dist gcc bz dist1 xgc)<br /> <br /> (setq ENOBJ (CAR (ENTSEL "\n请选择线段")))<br /> (setq p1 (getpoint "\n选择曲线上的一点："))<br />   (setq s1 (getreal "\n请输入该点标高："))<br /> (setq p2 (getpoint "\n选择曲线上的另一点："))<br /> (setq s2 (getreal "\n请输入该点标高："))<br />   (setq dist (apkl ENOBJ p1 p2 ))<br /> (setq gcc (- s1 s2))<br />   (setq bz (/ gcc dist))<br />   (while (setq p3 (getpoint "\n选择曲线上要查询的一点："))<br />     (setq dist1 (apkl ENOBJ p3 p2 ) )<br /> (setq xgc (+ s2 (* dist1 bz )))<br />     (entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))<br />    )<br /> (princ)<br />       )<br />

血司

测绘板块就你还活跃着

lizhigang.jin

; 错误: 输入的字符串有缺陷

508000096

文字如能垂直于曲线可能更加美观。

技术工作室

好东西顶一个

树櫴希德

1. (defun mkgcd (inspt height  scale  / pt  pt1 blkdef obj)
   
2.   (setvar "CMDECHO" 0)
   
3.   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")
   
4.   (if height
   
5.     (setq height (rtos height 2 3))
   
6.     (setq height "")
   
7.   )
   
8. 
   
9.   
   
10.   (regapp "SOUTH")
    
11.   ;;;检查字体 "HZ" 是否存在
    
12.   (if (not (tblobjname "style" "HZ"))
    
13.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    
14.   )
    
15.   ;;;检查是否存在高程点图块定义
    
16.   (if (not (tblobjname "block" "GC2000"))
    
17.     (progn
    
18.       ;13、entmake生成普通块
    
19. (defun emkblk ( pt name /  )
    
20.   (entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))
    
21. 
    
22.   
    
23. (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 10 (list (+ (car pt) 0.75)  (+ (cadr pt) 1)   ))(cons 10 pt) (cons 10 (list (- (car pt) 0.75)  (+ (cadr pt) 1)   ))
    
24. 
    
25. (cons 10 (list (+ (car pt) 4.25)  (+ (cadr pt) 1)   ))
    
26. 
    
27. 
    
28. 
    
29.          ))
    
30.   
    
31.   (entmake '((0 . "ENDBLK")))
    
32.   
    
33.   ;(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
    
34. )
    
35. 
    
36.   (emkblk '(0 0) "GC2000")
    
37.     )
    
38.   )
    
39.   ;;;插入块
    
40.   (entmake (list
    
41.              '(0 . "INSERT")
    
42.              '(100 . "AcDbEntity")
    
43.              '(100 . "AcDbBlockReference")
    
44.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
    
45.               (cons 2 "GC2000")
    
46.               (cons 10 inspt)
    
47.               (cons 41 scale)
    
48.               (cons 42 scale)
    
49.               (cons 43 scale)
    
50.               '(-3 ("SOUTH" (1000 . "202101")))
    
51.            )
    
52.   )
    
53.   ;;;插入属性
    
54.   (entmake (list
    
55.              '(0 . "ATTRIB")
    
56.              '(100 . "AcDbEntity")
    
57.              '(100 . "AcDbText")
    
58.               (cons 10 (setq pt (polar inspt (* 0.5 PI) (* 2.25 scale))))
    
59.               (cons 40 (* 2.0 scale))
    
60.               (cons 50 0)
    
61.                (cons 62 3)
    
62.               (cons 41 0.8)
    
63.               (cons 51 0)
    
64.               (cons 1 height)
    
65.               (cons 7 "HZ")
    
66.               (cons 72 0)
    
67.               (cons 11 pt)
    
68.               '(100 . "AcDbAttribute")
    
69.               (cons 2 "height")
    
70.               (cons 70  0)
    
71.               (cons 74 2)
    
72.            )
    
73.    )
    
74. ;;;;;;;;;;;;;;;;;;;;;;;
    
75. ;;;插入属性
    
76.   
    
77.   
    
78.    ;;;结束标志
    
79.    (entmake '((0 . "SEQEND")))
    
80.    (princ)
    
81. )
    
82. 
    
83. 
    
84. ;;;;;;;;===========================================
    
85. 
    
86. 
    
87. ;; 测量选定曲线上两点之间的距离
    
88. (defun apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)
    
89. ;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>箱,摄影  24942984
    
90.   
    
91.   
    
92. ;(setq ENOBJ (CAR (ENTSEL)))
    
93. ;(setq p1 (getpoint "\n选择曲线上的一点："))
    
94. ;(setq p2 (getpoint "\n选择曲线上的另一点："))
    
95. (setq dist1 (vlax-curve-getDistAtPoint enobj p1))
    
96. (setq dist2 (vlax-curve-getDistAtPoint enobj p2))
    
97. ;(print "\n测量段曲线长度：")
    
98. (setq dist (abs (- dist1 dist2)))
    
99. dist
    
100. )
     
101. 
     
102. (defun c:bg (  / ENOBJ p1 p2 s1 s2 p3  dist gcc bz dist1 xgc p33)
     
103. 
     
104. (setq ENOBJ (CAR (ENTSEL "\n请选择线段")))
     
105. (setq p1 (getpoint "\n选择曲线上的一点："))
     
106.   (setq s1 (getreal "\n请输入该点标高："))
     
107. (setq p2 (getpoint "\n选择曲线上的另一点："))
     
108. (setq s2 (getreal "\n请输入该点标高："))
     
109.   (setq dist (apkl ENOBJ p1 p2 ))
     
110. (setq gcc (- s1 s2))
     
111.   (setq bz (/ gcc dist))
     
112.   (while (setq p33 (getpoint "\n选择曲线上要查询的一点：")
     
113.                p3   (vlax-curve-getClosestPointTo ENOBJ p33 T)
     
114. 
     
115.          )
     
116.          
     
117.    
     
118.     (setq dist1 (apkl ENOBJ p3 p2 ) )
     
119. (setq xgc (+ s2 (* dist1 bz )))
     
120. 
     
121.     (mkgcd p3 xgc  1)
     
122.     (command "rotate" (entlast) "" p3 (* (- (angle p3 p33) (/ pi 2) ) (/ 180 pi) )  )
     
123.     ;(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
     
124.    )
     
125. (princ)
     
126.       )

(defun mkgcd (inspt height  scale  / pt  pt1 blkdef obj)<br />   (setvar "CMDECHO" 0)<br />   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")<br />   (if height<br />     (setq height (rtos height 2 3))<br />     (setq height "")<br />   )<br /> <br />   <br />   (regapp "SOUTH")<br />   ;;;检查字体 "HZ" 是否存在<br />   (if (not (tblobjname "style" "HZ"))<br />     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")<br />   )<br />   ;;;检查是否存在高程点图块定义<br />   (if (not (tblobjname "block" "GC2000"))<br />     (progn<br />       ;13、entmake生成普通块<br /> (defun emkblk ( pt name /  )<br />   (entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))<br /> <br />   <br /> (entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 4) (cons 10 (list (+ (car pt) 0.75)  (+ (cadr pt) 1)   ))(cons 10 pt) (cons 10 (list (- (car pt) 0.75)  (+ (cadr pt) 1)   ))<br /> <br /> (cons 10 (list (+ (car pt) 4.25)  (+ (cadr pt) 1)   ))<br /> <br /> <br /> <br />          ))<br />   <br />   (entmake '((0 . "ENDBLK")))<br />   <br />   ;(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))<br /> )<br /> <br />   (emkblk '(0 0) "GC2000")<br />     )<br />   )<br />   ;;;插入块<br />   (entmake (list<br />              '(0 . "INSERT")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbBlockReference")<br />              '(66 . 1);;;属性跟随标志,1跟随，0不跟随<br />               (cons 2 "GC2000")<br />               (cons 10 inspt)<br />               (cons 41 scale)<br />               (cons 42 scale)<br />               (cons 43 scale)<br />               '(-3 ("SOUTH" (1000 . "202101")))<br />            )<br />   )<br />   ;;;插入属性<br />   (entmake (list<br />              '(0 . "ATTRIB")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbText")<br />               (cons 10 (setq pt (polar inspt (* 0.5 PI) (* 2.25 scale))))<br />               (cons 40 (* 2.0 scale))<br />               (cons 50 0)<br />                (cons 62 3)<br />               (cons 41 0.8)<br />               (cons 51 0)<br />               (cons 1 height)<br />               (cons 7 "HZ")<br />               (cons 72 0)<br />               (cons 11 pt)<br />               '(100 . "AcDbAttribute")<br />               (cons 2 "height")<br />               (cons 70  0)<br />               (cons 74 2)<br />            )<br />    )<br /> ;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;插入属性<br />   <br />   <br />    ;;;结束标志<br />    (entmake '((0 . "SEQEND")))<br />    (princ)<br /> )<br /> <br /> <br /> ;;;;;;;;===========================================<br /> <br /> <br /> ;; 测量选定曲线上两点之间的距离<br /> (defun apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)<br /> ;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>箱,摄影  24942984<br />   <br />   <br /> ;(setq ENOBJ (CAR (ENTSEL)))<br /> ;(setq p1 (getpoint "\n选择曲线上的一点："))<br /> ;(setq p2 (getpoint "\n选择曲线上的另一点："))<br /> (setq dist1 (vlax-curve-getDistAtPoint enobj p1))<br /> (setq dist2 (vlax-curve-getDistAtPoint enobj p2))<br /> ;(print "\n测量段曲线长度：")<br /> (setq dist (abs (- dist1 dist2)))<br /> dist<br /> )<br /> <br /> (defun c:bg (  / ENOBJ p1 p2 s1 s2 p3  dist gcc bz dist1 xgc p33)<br /> <br /> (setq ENOBJ (CAR (ENTSEL "\n请选择线段")))<br /> (setq p1 (getpoint "\n选择曲线上的一点："))<br />   (setq s1 (getreal "\n请输入该点标高："))<br /> (setq p2 (getpoint "\n选择曲线上的另一点："))<br /> (setq s2 (getreal "\n请输入该点标高："))<br />   (setq dist (apkl ENOBJ p1 p2 ))<br /> (setq gcc (- s1 s2))<br />   (setq bz (/ gcc dist))<br />   (while (setq p33 (getpoint "\n选择曲线上要查询的一点：")<br />                p3   (vlax-curve-getClosestPointTo ENOBJ p33 T)<br /> <br />          )<br />          <br />     <br />     (setq dist1 (apkl ENOBJ p3 p2 ) )<br /> (setq xgc (+ s2 (* dist1 bz )))<br /> <br />     (mkgcd p3 xgc  1)<br />     (command "rotate" (entlast) "" p3 (* (- (angle p3 p33) (/ pi 2) ) (/ 180 pi) )  )<br />     ;(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))<br />    )<br /> (princ)<br />       )

czb203

树櫴希德 发表于 2022-10-14 23:31

大佬重出江湖啦～

无厘崖

这个对渐变高程分有用！

树櫴希德

148.954,80.6901

1. (vlax-curve-getClosestPointTo (vlax-ename->vla-object (car (entsel)))  (getpoint) )

(vlax-curve-getClosestPointTo (vlax-ename->vla-object (car (entsel)))  (getpoint) )