根据正确三角网计算坡顶或者坡脚位置

树櫴希德

2. ;;;by Gu_xl
   
3. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
   
4. (vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
   
5.   (regapp "SOUTH")
   
6.   (setvar "CMDECHO" 0)
   
7.   (command "layer" "m" "GCD" "c" "1" "" "L" "CONTINUOUS" ""  "")
   
8.   (if height
   
9.     (setq height (rtos height 2 3));3为高程注记位数
   
10.     (setq height "")
    
11.   )
    
12.   (regapp "SOUTH")
    
13.   
    
14.   ;;;检查字体 "HZ" 是否存在
    
15.   (if (not (tblobjname "style" "宋体"))
    
16.     ;(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    
17.     (command "style" "宋体" "" 0 1 0 "" "" "")
    
18.   )
    
19.   ;;;检查是否存在高程点图块定义
    
20.   (if (not (tblobjname "block" "GC200"))
    
21.     (progn
    
22.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
    
23.       (setq obj
    
24.         (vla-AddPolyline
    
25.            blkdef
    
26.            (vlax-make-variant
    
27.               (vlax-safearray-fill
    
28.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
    
29.                  '(-0.2 0 0 0.2 0 0)
    
30.               )
    
31.            )
    
32.         )
    
33.       )
    
34.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
    
35.       (vla-put-Closed obj :vlax-true)
    
36.       (vla-put-ConstantWidth obj 0.4)
    
37.     )
    
38.   )
    
39.   ;;;插入块
    
40.   (entmake (list
    
41.              '(0 . "INSERT")
    
42.              '(100 . "AcDbEntity")
    
43.              '(100 . "AcDbBlockReference")
    
44.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
    
45.               (cons 2 "GC200")
    
46.               (cons 10 inspt)
    
47.               (cons 41 scale)
    
48.               (cons 42 scale)
    
49.               (cons 43 scale)
    
50.               (list -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 (* 1.2 scale))))
    
59.               (cons 40 (* 2.0 scale))
    
60.               (cons 50 0)
    
61.               (cons 41 0.8)
    
62.               (cons 51 0)
    
63.               (cons 1 height)
    
64.               (cons 7 "宋体")
    
65.        (cons 62 3)
    
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.    (entmake '((0 . "SEQEND")))
    
76.    (princ)
    
77. )
    
78. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
79. (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1
    
80.       (setq n(length pt)
    
81.       pt(append pt(list(car pt)))i 0 ang 0)
    
82.       (while(< i n)
    
83.   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
    
84.   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
    
85.     (progn(cond((> va pi)(setq va (- va pi)))
    
86.          ((< va (* -1 pi))(setq va (+ va pi))))
    
87.       (setq ang(+ ang va)i(1+ i)))))
    
88.       (if(= ang 2)0
    
89.   (if(<(abs(-(abs ang) pi))0.000001)1 -1))
    
90.       )
    
91. ;defun
    
92. (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
    
93.     (setq a(vlax-ename->vla-object e)
    
94.   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
    
95.     m(vla-get-objectname a)a 0
    
96.     m(if(= m"AcDb3dPolyline")3 2))
    
97.     (repeat(/(length q)m)
    
98.       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
    
99.      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
    
100.       (setq p(if (member p1 p)p (append p(list p1)))
     
101.       a(+ a m)))
     
102.     p)
     
103. (defun xyp-Pline (lst / lst pt)
     
104. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))
     
105.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
     
106.   ) (vl-cmdf "_.region" (entlast) "") (entlast)
     
107. )
     
108. ;;改改更贱康
     
109. (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)
     
110.   (defun MAT:vxv (u v)
     
111.     (list
     
112.       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
     
113.       (- (* (car v) (caddr u)) (* (car u) (caddr v)))
     
114.       (- (* (car u) (cadr v)) (* (car v) (cadr u)))
     
115.     )
     
116.   )
     
117.   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))
     
118.   (setq {v} (mapcar '- pa pb))
     
119.   (setq  a (apply '+
     
120. (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})
     
121.   )
     
122.   )
     
123.   (setq b (apply '+ (mapcar '* {vp} {v})))
     
124.   (if (equal b 0.0 1e-6)
     
125.     nil
     
126.     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})
     
127.   )
     
128. )
     
129. (defun insertgc ( e / e)
     
130.   (cdr(assoc 10(entget e)))  )
     
131. 
     
132. (defun c:pdpj ( / podu p1 p2 ang pts ssa ii no en ptb pzx pts1 pzx1 x blc scale pt ptlst zpt)
     
133.   
     
134.   (setq blc (getint "\n请输入比例尺1:<500>"))
     
135.   (if (= blc nil)(setq blc 500))
     
136.   (setvar 'userr1 blc);设置比例尺
     
137. (setq scale (* 0.001 blc));缩放比例
     
138.   
     
139.   (setq podu (getreal "\n请输入坡度1：(挖+填-)?"))
     
140.   (setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))
     
141. (setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))
     
142. (setq p2 (polar p1 ang 100))
     
143.   (setq pts1 (list p1 (append (vl-remove (last p2)p2) (list(+ (last p1 )(/ 100  podu ))))  ))
     
144.   ;(print pts1)
     
145.   (setq pts (list (vl-remove (last p1)p1) p2))
     
146.   (vl-cmdf "zoom" "e")
     
147. (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))
     
148. ;(sssetfirst nil ssa)
     
149. (setq ii   0  no  0)
     
150.                   (repeat (sslength ssa)
     
151.                        (setq en (ssname ssa ii)
     
152.                             ptb (plinexy en)
     
153.            ;demj (vlax-curve-getArea  (vlax-ename->vla-object en))
     
154.           pzx (append pzx (list ptb))
     
155. 
     
156.            ii  (1+ ii)  )                  
     
157.                   )
     
158. 
     
159.      
     
160. 
     
161.   ;(setvar "osmode"16384)
     
162. (foreach x pzx
     
163.   
     
164.   (setq pzx1 (temp (car pts1) (cadr pts1) (car x) (cadr x)(caddr x)   ))
     
165. (if (and (/= pzx1 nil)
     
166.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )x) (vl-remove (last pzx1)pzx1)  )0)  )
     
167.   (progn (print pzx1)(gxl-cs:gcd pzx1 (last pzx1) scale))
     
168.   )
     
169. 
     
170.   )
     
171.   
     
172.   
     
173.       )
     

;;;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 ( / podu p1 p2 ang pts ssa ii no en ptb pzx pts1 pzx1 x blc scale pt ptlst zpt) <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 />   (setq p1 (insertgc(car(entsel "\n请选择坡顶或者坡脚："))))<br /> (setq ang (getangle p1 "\n请指定顶或者坡脚哪个方向? "))<br /> (setq p2 (polar p1 ang 100))<br />   (setq pts1 (list p1 (append (vl-remove (last p2)p2) (list(+ (last p1 )(/ 100  podu ))))  ))<br />   ;(print pts1)<br />   (setq pts (list (vl-remove (last p1)p1) p2))<br />   (vl-cmdf "zoom" "e")<br /> (setq ssa (ssget "f" pts'((0 . "POLYLINE") (8 . "sjw"))))<br /> ;(sssetfirst nil ssa)<br /> (setq ii   0  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 />   <br />   <br />       )<br />

树櫴希德

三角网符合地形 坡顶坡脚位置才准确

88641787

你好    请问如何使用   

竹林玉缘

请问楼主，如何使用

zzyong00

首先，三角网是用什么生成 的？

竹林玉缘

请问楼主，如何使用