根据三角网计算开挖边坡顶线，高程要够密度准确些PDPJ

树櫴希德

根据三角网计算开挖边坡顶线，高程要够密度准确些

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:bg11 (  / 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.       )
     
127. 
     
128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
129. ;;;by Gu_xl
     
130. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
     
131. (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
     
132.   (regapp "SOUTH")
     
133.   (setvar "CMDECHO" 0)
     
134.   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
     
135.   (if height
     
136.     (setq height (rtos height 2 3));3为高程注记位数
     
137.     (setq height "")
     
138.   )
     
139.   (regapp "SOUTH")
     
140.   
     
141.   ;;;检查字体 "HZ" 是否存在
     
142.   (if (not (tblobjname "style" "宋体"))
     
143.     ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
     
144.     (command "style" "宋体" "" 0 1 0 "" "" "")
     
145.   )
     
146.   ;;;检查是否存在高程点图块定义
     
147.   (if (not (tblobjname "block" "GC200"))
     
148.     (progn
     
149.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
     
150.       (setq obj
     
151.         (vla-AddPolyline
     
152.            blkdef
     
153.            (vlax-make-variant
     
154.               (vlax-safearray-fill
     
155.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
     
156.                  '(-0.2 0 0 0.2 0 0)
     
157.               )
     
158.            )
     
159.         )
     
160.       )
     
161.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
     
162.       (vla-put-Closed obj :vlax-true)
     
163.       (vla-put-ConstantWidth obj 0.4)
     
164.     )
     
165.   )
     
166.   ;;;插入块
     
167.   (entmake (list
     
168.              '(0 . "INSERT")
     
169.              '(100 . "AcDbEntity")
     
170.              '(100 . "AcDbBlockReference")
     
171.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
     
172.               (cons 2 "GC200")
     
173.               (cons 10 inspt)
     
174.               (cons 41 scale)
     
175.               (cons 42 scale)
     
176.               (cons 43 scale)
     
177.               (list -3 '("SOUTH" (1000 . "202101")))
     
178.            )
     
179.   )
     
180.   ;;;插入属性
     
181.   (entmake (list
     
182.              '(0 . "ATTRIB")
     
183.              '(100 . "AcDbEntity")
     
184.              '(100 . "AcDbText")
     
185.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
     
186.               (cons 40 (* 2.0 scale))
     
187.               (cons 50 0)
     
188.               (cons 41 0.8)
     
189.               (cons 51 0)
     
190.               (cons 1 height)
     
191.               (cons 7 "宋体")
     
192.        (cons 62 3)
     
193.               (cons 72 0)
     
194.               (cons 11 pt)
     
195.               '(100 . "AcDbAttribute")
     
196.               (cons 2 "height")
     
197.               (cons 70  0)
     
198.               (cons 74 2)
     
199.            )
     
200.    )
     
201.    ;;;结束标志
     
202.    (entmake '((0 . "SEQEND")))
     
203.    (princ)
     
204. )
     
205. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
206. (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1
     
207.       (setq n(length pt)
     
208.       pt(append pt(list(car pt)))i 0 ang 0)
     
209.       (while(< i n)
     
210.   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
     
211.   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
     
212.     (progn(cond((> va pi)(setq va (- va pi)))
     
213.          ((< va (* -1 pi))(setq va (+ va pi))))
     
214.       (setq ang(+ ang va)i(1+ i)))))
     
215.       (if(= ang 2)0
     
216.   (if(<(abs(-(abs ang) pi))0.000001)1 -1))
     
217.       )
     
218. ;defun
     
219. (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
     
220.     (setq a(vlax-ename->vla-object e)
     
221.   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
     
222.     m(vla-get-objectname a)a 0
     
223.     m(if(= m"AcDb3dPolyline")3 2))
     
224.     (repeat(/(length q)m)
     
225.       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
     
226.      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
     
227.       (setq p(if (member p1 p)p (append p(list p1)))
     
228.       a(+ a m)))
     
229.     p)
     
230. (defun xyp-Pline (lst / lst pt)
     
231. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))
     
232.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
     
233.   ) (vl-cmdf "_.region" (entlast) "") (entlast)
     
234. )
     
235. ;;改改更贱康
     
236. (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)
     
237.   (defun MAT:vxv (u v)
     
238.     (list
     
239.       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
     
240.       (- (* (car v) (caddr u)) (* (car u) (caddr v)))
     
241.       (- (* (car u) (cadr v)) (* (car v) (cadr u)))
     
242.     )
     
243.   )
     
244.   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))
     
245.   (setq {v} (mapcar '- pa pb))
     
246.   (setq  a (apply '+
     
247. (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})
     
248.   )
     
249.   )
     
250.   (setq b (apply '+ (mapcar '* {vp} {v})))
     
251.   (if (equal b 0.0 1e-6)
     
252.     nil
     
253.     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})
     
254.   )
     
255. )
     
256. (defun insertgc ( e / e)
     
257.   (cdr(assoc 10(entget e)))  )
     
258. 
     
259. (defun c:pdpj (   /  ENOBJ p1 p2 s1 s2 p3 p33 dist gcc bz dist1 xgc p33 podu blc  p11 ang p22 pts1 pts ssa ii en ptb pzx pzx1 no)
     
260.   
     
261.   (setq blc (getint "\n请输入比例尺1:<500>"))
     
262.   (if (= blc nil)(setq blc 500))
     
263.   (setvar 'userr1 blc);设置比例尺
     
264. (setq scale (* 0.001 blc));缩放比例
     
265.   
     
266.   (setq podu (getreal "\n请输入坡度1：(挖+填-)?"))
     
267. 
     
268.   ;;;;;
     
269.   (setq ENOBJ (CAR (ENTSEL "\n请选择线段")))
     
270. (setq p1 (getpoint "\n选择曲线上的一点："))
     
271.   (setq s1 (getreal "\n请输入该点标高："))
     
272. (setq p2 (getpoint "\n选择曲线上的另一点："))
     
273. (setq s2 (getreal "\n请输入该点标高："))
     
274.   (setq dist (apkl ENOBJ p1 p2 ))
     
275. (setq gcc (- s1 s2))
     
276.   (setq bz (/ gcc dist))
     
277.   (while (setq p33 (getpoint "\n选择曲线上要查询的一点：")
     
278.               
     
279. 
     
280.          )
     
281.          (setq  p3   (vlax-curve-getClosestPointTo ENOBJ p33 T))
     
282.    
     
283.     (setq dist1 (apkl ENOBJ p3 p2 ) )
     
284. (setq xgc (+ s2 (* dist1 bz )))
     
285. 
     
286.     ;(mkgcd p3 xgc  1)
     
287.     (gxl-cs:gcd p3 xgc scale)
     
288. ;(setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))
     
289.     (setq p11 (list (car p3 ) (cadr p3) xgc))
     
290. ;(setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))
     
291.    (setq ang  (angle p11 p33))
     
292. (setq p22 (polar p11 ang 100))
     
293.   (setq pts1 (list p11 (append (vl-remove (last p22)p22) (list(+ (last p11 )(/ 100  podu ))))  ))
     
294.   ;(print pts1)
     
295.   (setq pts (list (vl-remove (last p11)p11) p22))
     
296.   (vl-cmdf "zoom" "e")
     
297. (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))
     
298. ;(sssetfirst nil ssa)
     
299. (setq ii   0
     
300.        no  0)
     
301.                   (repeat (sslength ssa)
     
302.                        (setq en (ssname ssa ii)
     
303.                             ptb (plinexy en)
     
304.            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))
     
305.           pzx (append pzx (list ptb))
     
306. 
     
307.            ii  (1+ ii)  )                  
     
308.                   )
     
309. 
     
310.      
     
311. 
     
312.   ;(setvar "osmode"16384)
     
313. (foreach x pzx
     
314.   
     
315.   (setq pzx1 (temp (car pts1) (cadr pts1) (car x) (cadr x)(caddr x)   ))
     
316. (if (and (/= pzx1 nil)
     
317.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )x) (vl-remove (last pzx1)pzx1)  )0)  )
     
318.   (progn (print pzx1)(gxl-cs:gcd pzx1 (last pzx1) scale))
     
319.   )
     
320. 
     
321.   )
     
322.     (vl-cmdf "zoom" "p")
     
323.     ;(command "rotate" (entlast) "" p3 (* (- (angle p3 p33) (/ pi 2) ) (/ 180 pi) )  )
     
324.     ;(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
     
325.    )
     
326. (princ)
     
327.   
     
328.       )

(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 href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a></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:bg11 (  / 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 />       )<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;by Gu_xl<br /> (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)<br /> (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP<br />   (regapp "SOUTH")<br />   (setvar "CMDECHO" 0)<br />   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")<br />   (if height<br />     (setq height (rtos height 2 3));3为高程注记位数<br />     (setq height "")<br />   )<br />   (regapp "SOUTH")<br />   <br />   ;;;检查字体 "HZ" 是否存在<br />   (if (not (tblobjname "style" "宋体"))<br />     ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")<br />     (command "style" "宋体" "" 0 1 0 "" "" "")<br />   )<br />   ;;;检查是否存在高程点图块定义<br />   (if (not (tblobjname "block" "GC200"))<br />     (progn<br />       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))<br />       (setq obj<br />         (vla-AddPolyline<br />            blkdef<br />            (vlax-make-variant<br />               (vlax-safearray-fill<br />                  (vlax-make-safearray vlax-vbdouble (cons 0 5))<br />                  '(-0.2 0 0 0.2 0 0)<br />               )<br />            )<br />         )<br />       )<br />       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)<br />       (vla-put-Closed obj :vlax-true)<br />       (vla-put-ConstantWidth obj 0.4)<br />     )<br />   )<br />   ;;;插入块<br />   (entmake (list<br />              '(0 . "INSERT")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbBlockReference")<br />              '(66 . 1);;;属性跟随标志,1跟随，0不跟随<br />               (cons 2 "GC200")<br />               (cons 10 inspt)<br />               (cons 41 scale)<br />               (cons 42 scale)<br />               (cons 43 scale)<br />               (list -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 (* 1.2 scale))))<br />               (cons 40 (* 2.0 scale))<br />               (cons 50 0)<br />               (cons 41 0.8)<br />               (cons 51 0)<br />               (cons 1 height)<br />               (cons 7 "宋体")<br />        (cons 62 3)<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 />    (entmake '((0 . "SEQEND")))<br />    (princ)<br /> )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1<br />       (setq n(length pt)<br />       pt(append pt(list(car pt)))i 0 ang 0)<br />       (while(< i n)<br />   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))<br />   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)<br />     (progn(cond((> va pi)(setq va (- va pi)))<br />          ((< va (* -1 pi))(setq va (+ va pi))))<br />       (setq ang(+ ang va)i(1+ i)))))<br />       (if(= ang 2)0<br />   (if(<(abs(-(abs ang) pi))0.000001)1 -1))<br />       )<br /> ;defun<br /> (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点<br />     (setq a(vlax-ename->vla-object e)<br />   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))<br />     m(vla-get-objectname a)a 0<br />     m(if(= m"AcDb3dPolyline")3 2))<br />     (repeat(/(length q)m)<br />       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))<br />      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))<br />       (setq p(if (member p1 p)p (append p(list p1)))<br />       a(+ a m)))<br />     p)<br /> (defun xyp-Pline (lst / lst pt)<br /> (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))<br />       (mapcar '(lambda (pt)(cons 10 pt)) lst ))<br />   ) (vl-cmdf "_.region" (entlast) "") (entlast)<br /> )<br /> ;;改改更贱康<br /> (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)<br />   (defun MAT:vxv (u v)<br />     (list<br />       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))<br />       (- (* (car v) (caddr u)) (* (car u) (caddr v)))<br />       (- (* (car u) (cadr v)) (* (car v) (cadr u)))<br />     )<br />   )<br />   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))<br />   (setq {v} (mapcar '- pa pb))<br />   (setq  a (apply '+<br /> (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})<br />   )<br />   )<br />   (setq b (apply '+ (mapcar '* {vp} {v})))<br />   (if (equal b 0.0 1e-6)<br />     nil<br />     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})<br />   )<br /> )<br /> (defun insertgc ( e / e)<br />   (cdr(assoc 10(entget e)))  )<br /> <br /> (defun c:pdpj (   /  ENOBJ p1 p2 s1 s2 p3 p33 dist gcc bz dist1 xgc p33 podu blc  p11 ang p22 pts1 pts ssa ii en ptb pzx pzx1 no) <br />   <br />   (setq blc (getint "\n请输入比例尺1:<500>"))<br />   (if (= blc nil)(setq blc 500))<br />   (setvar 'userr1 blc);设置比例尺<br /> (setq scale (* 0.001 blc));缩放比例<br />   <br />   (setq podu (getreal "\n请输入坡度1：(挖+填-)?"))<br /> <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 />               <br /> <br />          )<br />          (setq  p3   (vlax-curve-getClosestPointTo ENOBJ p33 T))<br />     <br />     (setq dist1 (apkl ENOBJ p3 p2 ) )<br /> (setq xgc (+ s2 (* dist1 bz )))<br /> <br />     ;(mkgcd p3 xgc  1)<br />     (gxl-cs:gcd p3 xgc scale)<br /> ;(setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))<br />     (setq p11 (list (car p3 ) (cadr p3) xgc))<br /> ;(setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))<br />    (setq ang  (angle p11 p33)) <br /> (setq p22 (polar p11 ang 100))<br />   (setq pts1 (list p11 (append (vl-remove (last p22)p22) (list(+ (last p11 )(/ 100  podu ))))  ))<br />   ;(print pts1)<br />   (setq pts (list (vl-remove (last p11)p11) p22))<br />   (vl-cmdf "zoom" "e")<br /> (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))<br /> ;(sssetfirst nil ssa)<br /> (setq ii   0<br />        no  0)<br />                   (repeat (sslength ssa)<br />                        (setq en (ssname ssa ii)<br />                             ptb (plinexy en)<br />            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))<br />           pzx (append pzx (list ptb))<br /> <br />            ii  (1+ ii)  )                  <br />                   )<br /> <br />      <br /> <br />   ;(setvar "osmode"16384)<br /> (foreach x pzx<br />   <br />   (setq pzx1 (temp (car pts1) (cadr pts1) (car x) (cadr x)(caddr x)   ))<br /> (if (and (/= pzx1 nil)<br />     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )x) (vl-remove (last pzx1)pzx1)  )0)  )<br />   (progn (print pzx1)(gxl-cs:gcd pzx1 (last pzx1) scale))<br />   )<br /> <br />   )<br />     (vl-cmdf "zoom" "p")<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 />   <br />       )

ynpxqjlb

厉害！！！！！！

树櫴希德

1. (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object (car(entsel)))  (getpoint) '(0.0 0.0 1.0) t)

复制代码

在将曲线投影到平面上之后，返回曲线上的最近点（在 WCS 上）

(vlax-curve-getClosestPointToProjection curve-obj  givenPnt normal [extend])

说明

1）参数 curve-obj 为要测量的 VLA 对象。

2）参数 givenPnt 为WCS 中的点，在曲线上寻找该点的最近点。

3）参数 normal 为WCS 中的法线矢量，指定投影平面。

4）参数 extend 若指定该参数且其值不为 nil，vlax-curve-getClosestPointToProjection 在搜索最近点时扩展曲线。

5）vlax-curve-getClosestPointToProjection 先将曲线投影到由 givenPnt 和 normal 定义的平面上，后在该平面上计算距 givenPnt 最近的点。最后，vlax-curve-getClosestPointToProjection 将结果点重新投影到原来的曲线上，并返回投影后的点。

返回值：

若成功，则返回表示曲线上一点的三维点表，否则返回 nil

树櫴希德

1. (entmake (list '(0 . "CIRCLE") (cons 10 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object (car(entsel)))  (getpoint) '(0.0 0.0 1.0) t)) (cons 40 5)))

(entmake (list '(0 . "CIRCLE") (cons 10 (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object (car(entsel)))  (getpoint) '(0.0 0.0 1.0) t)) (cons 40 5)))

树櫴希德

如果坡顶坡脚是三维多段线还好用一些

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:bg11 (  / 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.       )
     
127. 
     
128. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
129. ;;;by Gu_xl
     
130. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
     
131. (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
     
132.   (regapp "SOUTH")
     
133.   (setvar "CMDECHO" 0)
     
134.   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
     
135.   (if height
     
136.     (setq height (rtos height 2 3));3为高程注记位数
     
137.     (setq height "")
     
138.   )
     
139.   (regapp "SOUTH")
     
140.   
     
141.   ;;;检查字体 "HZ" 是否存在
     
142.   (if (not (tblobjname "style" "宋体"))
     
143.     ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
     
144.     (command "style" "宋体" "" 0 1 0 "" "" "")
     
145.   )
     
146.   ;;;检查是否存在高程点图块定义
     
147.   (if (not (tblobjname "block" "GC200"))
     
148.     (progn
     
149.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
     
150.       (setq obj
     
151.         (vla-AddPolyline
     
152.            blkdef
     
153.            (vlax-make-variant
     
154.               (vlax-safearray-fill
     
155.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
     
156.                  '(-0.2 0 0 0.2 0 0)
     
157.               )
     
158.            )
     
159.         )
     
160.       )
     
161.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
     
162.       (vla-put-Closed obj :vlax-true)
     
163.       (vla-put-ConstantWidth obj 0.4)
     
164.     )
     
165.   )
     
166.   ;;;插入块
     
167.   (entmake (list
     
168.              '(0 . "INSERT")
     
169.              '(100 . "AcDbEntity")
     
170.              '(100 . "AcDbBlockReference")
     
171.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
     
172.               (cons 2 "GC200")
     
173.               (cons 10 inspt)
     
174.               (cons 41 scale)
     
175.               (cons 42 scale)
     
176.               (cons 43 scale)
     
177.               (list -3 '("SOUTH" (1000 . "202101")))
     
178.            )
     
179.   )
     
180.   ;;;插入属性
     
181.   (entmake (list
     
182.              '(0 . "ATTRIB")
     
183.              '(100 . "AcDbEntity")
     
184.              '(100 . "AcDbText")
     
185.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
     
186.               (cons 40 (* 2.0 scale))
     
187.               (cons 50 0)
     
188.               (cons 41 0.8)
     
189.               (cons 51 0)
     
190.               (cons 1 height)
     
191.               (cons 7 "宋体")
     
192.        (cons 62 3)
     
193.               (cons 72 0)
     
194.               (cons 11 pt)
     
195.               '(100 . "AcDbAttribute")
     
196.               (cons 2 "height")
     
197.               (cons 70  0)
     
198.               (cons 74 2)
     
199.            )
     
200.    )
     
201.    ;;;结束标志
     
202.    (entmake '((0 . "SEQEND")))
     
203.    (princ)
     
204. )
     
205. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
206. (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1
     
207.       (setq n(length pt)
     
208.       pt(append pt(list(car pt)))i 0 ang 0)
     
209.       (while(< i n)
     
210.   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
     
211.   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
     
212.     (progn(cond((> va pi)(setq va (- va pi)))
     
213.          ((< va (* -1 pi))(setq va (+ va pi))))
     
214.       (setq ang(+ ang va)i(1+ i)))))
     
215.       (if(= ang 2)0
     
216.   (if(<(abs(-(abs ang) pi))0.000001)1 -1))
     
217.       )
     
218. ;defun
     
219. (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
     
220.     (setq a(vlax-ename->vla-object e)
     
221.   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
     
222.     m(vla-get-objectname a)a 0
     
223.     m(if(= m"AcDb3dPolyline")3 2))
     
224.     (repeat(/(length q)m)
     
225.       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
     
226.      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
     
227.       (setq p(if (member p1 p)p (append p(list p1)))
     
228.       a(+ a m)))
     
229.     p)
     
230. (defun xyp-Pline (lst / lst pt)
     
231. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))
     
232.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
     
233.   ) (vl-cmdf "_.region" (entlast) "") (entlast)
     
234. )
     
235. ;;改改更贱康
     
236. (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)
     
237.   (defun MAT:vxv (u v)
     
238.     (list
     
239.       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
     
240.       (- (* (car v) (caddr u)) (* (car u) (caddr v)))
     
241.       (- (* (car u) (cadr v)) (* (car v) (cadr u)))
     
242.     )
     
243.   )
     
244.   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))
     
245.   (setq {v} (mapcar '- pa pb))
     
246.   (setq  a (apply '+
     
247. (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})
     
248.   )
     
249.   )
     
250.   (setq b (apply '+ (mapcar '* {vp} {v})))
     
251.   (if (equal b 0.0 1e-6)
     
252.     nil
     
253.     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})
     
254.   )
     
255. )
     
256. (defun insertgc ( e / e)
     
257.   (cdr(assoc 10(entget e)))  )
     
258. 
     
259. (defun c:pdpj3 (   /  ENOBJ p1 p2 s1 s2 p3 p33 dist gcc bz dist1 xgc p33 podu blc  p11 ang p22 pts1 pts ssa ii en ptb pzx pzx1 no)
     
260.   
     
261.   (setq blc (getint "\n请输入比例尺1:<500>"))
     
262.   (if (= blc nil)(setq blc 500))
     
263.   (setvar 'userr1 blc);设置比例尺
     
264. (setq scale (* 0.001 blc));缩放比例
     
265.   
     
266.   (setq podu (getreal "\n请输入坡度1：(挖+填-)?"))
     
267. 
     
268.   ;;;;;
     
269.   (setq ENOBJ (CAR (ENTSEL "\n请选择坡顶或者坡脚三维多段线POLYLINE线段")))
     
270. ;(setq p1 (getpoint "\n选择曲线上的一点："))
     
271.   ;(setq s1 (getreal "\n请输入该点标高："))
     
272. ;(setq p2 (getpoint "\n选择曲线上的另一点："))
     
273. ;(setq s2 (getreal "\n请输入该点标高："))
     
274.   ;(setq dist (apkl ENOBJ p1 p2 ))
     
275. ;(setq gcc (- s1 s2))
     
276.   ;(setq bz (/ gcc dist))
     
277.   (while (setq p33 (getpoint "\n选择曲线上要查询的一点：")                    )
     
278.    
     
279.          ;(setq  p3   (vlax-curve-getClosestPointTo ENOBJ p33 T))
     
280.     (setq  p3   (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object ENOBJ)  p33 '(0.0 0.0 1.0) t))
     
281.     ;(setq dist1 (apkl ENOBJ p3 p2 ) )
     
282. ;(setq xgc (+ s2 (* dist1 bz )))
     
283. 
     
284.     ;(mkgcd p3 xgc  1)
     
285.     (gxl-cs:gcd p3 (last p3) scale)
     
286. ;(setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))
     
287.     (setq p11 (list (car p3 ) (cadr p3) (last p3) ))
     
288. ;(setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))
     
289.    (setq ang  (angle p11 p33))
     
290. (setq p22 (polar p11 ang 100))
     
291.   (setq pts1 (list p11 (append (vl-remove (last p22)p22) (list(+ (last p11 )(/ 100  podu ))))  ))
     
292.   ;(print pts1)
     
293.   (setq pts (list (vl-remove (last p11)p11) p22))
     
294.   (vl-cmdf "zoom" "e")
     
295. (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))
     
296. ;(sssetfirst nil ssa)
     
297. (setq ii   0
     
298.        no  0)
     
299.                   (repeat (sslength ssa)
     
300.                        (setq en (ssname ssa ii)
     
301.                             ptb (plinexy en)
     
302.            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))
     
303.           pzx (append pzx (list ptb))
     
304. 
     
305.            ii  (1+ ii)  )                  
     
306.                   )
     
307. 
     
308.      
     
309. 
     
310.   ;(setvar "osmode"16384)
     
311. (foreach x pzx
     
312.   
     
313.   (setq pzx1 (temp (car pts1) (cadr pts1) (car x) (cadr x)(caddr x)   ))
     
314. (if (and (/= pzx1 nil)
     
315.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )x) (vl-remove (last pzx1)pzx1)  )0)  )
     
316.   (progn (print pzx1)(gxl-cs:gcd pzx1 (last pzx1) scale))
     
317.   )
     
318. 
     
319.   )
     
320.     (vl-cmdf "zoom" "p")
     
321.     ;(command "rotate" (entlast) "" p3 (* (- (angle p3 p33) (/ pi 2) ) (/ 180 pi) )  )
     
322.     ;(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
     
323.    )
     
324. (princ)
     
325.   
     
326.       )

(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:bg11 (  / 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 />       )<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> ;;;by Gu_xl<br /> (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)<br /> (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP<br />   (regapp "SOUTH")<br />   (setvar "CMDECHO" 0)<br />   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")<br />   (if height<br />     (setq height (rtos height 2 3));3为高程注记位数<br />     (setq height "")<br />   )<br />   (regapp "SOUTH")<br />   <br />   ;;;检查字体 "HZ" 是否存在<br />   (if (not (tblobjname "style" "宋体"))<br />     ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")<br />     (command "style" "宋体" "" 0 1 0 "" "" "")<br />   )<br />   ;;;检查是否存在高程点图块定义<br />   (if (not (tblobjname "block" "GC200"))<br />     (progn<br />       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))<br />       (setq obj<br />         (vla-AddPolyline<br />            blkdef<br />            (vlax-make-variant<br />               (vlax-safearray-fill<br />                  (vlax-make-safearray vlax-vbdouble (cons 0 5))<br />                  '(-0.2 0 0 0.2 0 0)<br />               )<br />            )<br />         )<br />       )<br />       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)<br />       (vla-put-Closed obj :vlax-true)<br />       (vla-put-ConstantWidth obj 0.4)<br />     )<br />   )<br />   ;;;插入块<br />   (entmake (list<br />              '(0 . "INSERT")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbBlockReference")<br />              '(66 . 1);;;属性跟随标志,1跟随，0不跟随<br />               (cons 2 "GC200")<br />               (cons 10 inspt)<br />               (cons 41 scale)<br />               (cons 42 scale)<br />               (cons 43 scale)<br />               (list -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 (* 1.2 scale))))<br />               (cons 40 (* 2.0 scale))<br />               (cons 50 0)<br />               (cons 41 0.8)<br />               (cons 51 0)<br />               (cons 1 height)<br />               (cons 7 "宋体")<br />        (cons 62 3)<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 />    (entmake '((0 . "SEQEND")))<br />    (princ)<br /> )<br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1<br />       (setq n(length pt)<br />       pt(append pt(list(car pt)))i 0 ang 0)<br />       (while(< i n)<br />   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))<br />   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)<br />     (progn(cond((> va pi)(setq va (- va pi)))<br />          ((< va (* -1 pi))(setq va (+ va pi))))<br />       (setq ang(+ ang va)i(1+ i)))))<br />       (if(= ang 2)0<br />   (if(<(abs(-(abs ang) pi))0.000001)1 -1))<br />       )<br /> ;defun<br /> (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点<br />     (setq a(vlax-ename->vla-object e)<br />   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))<br />     m(vla-get-objectname a)a 0<br />     m(if(= m"AcDb3dPolyline")3 2))<br />     (repeat(/(length q)m)<br />       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))<br />      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))<br />       (setq p(if (member p1 p)p (append p(list p1)))<br />       a(+ a m)))<br />     p)<br /> (defun xyp-Pline (lst / lst pt)<br /> (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))<br />       (mapcar '(lambda (pt)(cons 10 pt)) lst ))<br />   ) (vl-cmdf "_.region" (entlast) "") (entlast)<br /> )<br /> ;;改改更贱康<br /> (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)<br />   (defun MAT:vxv (u v)<br />     (list<br />       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))<br />       (- (* (car v) (caddr u)) (* (car u) (caddr v)))<br />       (- (* (car u) (cadr v)) (* (car v) (cadr u)))<br />     )<br />   )<br />   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))<br />   (setq {v} (mapcar '- pa pb))<br />   (setq  a (apply '+<br /> (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})<br />   )<br />   )<br />   (setq b (apply '+ (mapcar '* {vp} {v})))<br />   (if (equal b 0.0 1e-6)<br />     nil<br />     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})<br />   )<br /> )<br /> (defun insertgc ( e / e)<br />   (cdr(assoc 10(entget e)))  )<br /> <br /> (defun c:pdpj3 (   /  ENOBJ p1 p2 s1 s2 p3 p33 dist gcc bz dist1 xgc p33 podu blc  p11 ang p22 pts1 pts ssa ii en ptb pzx pzx1 no) <br />   <br />   (setq blc (getint "\n请输入比例尺1:<500>"))<br />   (if (= blc nil)(setq blc 500))<br />   (setvar 'userr1 blc);设置比例尺<br /> (setq scale (* 0.001 blc));缩放比例<br />   <br />   (setq podu (getreal "\n请输入坡度1：(挖+填-)?"))<br /> <br />   ;;;;;<br />   (setq ENOBJ (CAR (ENTSEL "\n请选择坡顶或者坡脚三维多段线POLYLINE线段")))<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 />     <br />          ;(setq  p3   (vlax-curve-getClosestPointTo ENOBJ p33 T))<br />     (setq  p3   (vlax-curve-getClosestPointToProjection (vlax-ename->vla-object ENOBJ)  p33 '(0.0 0.0 1.0) t))<br />     ;(setq dist1 (apkl ENOBJ p3 p2 ) )<br /> ;(setq xgc (+ s2 (* dist1 bz )))<br /> <br />     ;(mkgcd p3 xgc  1)<br />     (gxl-cs:gcd p3 (last p3) scale)<br /> ;(setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))<br />     (setq p11 (list (car p3 ) (cadr p3) (last p3) ))<br /> ;(setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))<br />    (setq ang  (angle p11 p33)) <br /> (setq p22 (polar p11 ang 100))<br />   (setq pts1 (list p11 (append (vl-remove (last p22)p22) (list(+ (last p11 )(/ 100  podu ))))  ))<br />   ;(print pts1)<br />   (setq pts (list (vl-remove (last p11)p11) p22))<br />   (vl-cmdf "zoom" "e")<br /> (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))<br /> ;(sssetfirst nil ssa)<br /> (setq ii   0<br />        no  0)<br />                   (repeat (sslength ssa)<br />                        (setq en (ssname ssa ii)<br />                             ptb (plinexy en)<br />            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))<br />           pzx (append pzx (list ptb))<br /> <br />            ii  (1+ ii)  )                  <br />                   )<br /> <br />      <br /> <br />   ;(setvar "osmode"16384)<br /> (foreach x pzx<br />   <br />   (setq pzx1 (temp (car pts1) (cadr pts1) (car x) (cadr x)(caddr x)   ))<br /> (if (and (/= pzx1 nil)<br />     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )x) (vl-remove (last pzx1)pzx1)  )0)  )<br />   (progn (print pzx1)(gxl-cs:gcd pzx1 (last pzx1) scale))<br />   )<br /> <br />   )<br />     (vl-cmdf "zoom" "p")<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 />   <br />       )

czb203

老哥，这个厉害了，一直都在纠结这问题