cass横断面数据转高程

树櫴希德

数不清大神们的函数 有GU版等

1. (gc)
   
2. (vl-load-com)
   
3. ;;;;;;;;;;;;;;;;;;;
   
4. (defun str->pt (str)
   
5.     (XD::Pnt:SetZ
   
6.       (mapcar 'distof (cdr (String:Split str ",")))
   
7.       0.
   
8.     )
   
9.   )
   
10. 
    
11. ;;;;;;;;;;;
    
12. (defun String:Split (str delimiter / post strlst stl)
    
13.     (if        str
    
14.       (progn
    
15.         (setq stl (strlen delimiter))
    
16.         (while (vl-string-search delimiter str)
    
17.           (setq        post   (vl-string-search delimiter str)
    
18.                 strlst (cons (substr str 1 post) strlst)
    
19.                 str    (substr str (+ 1 post stl))
    
20.           )
    
21.         )
    
22.         (reverse (vl-remove "" (cons str strlst)))
    
23.       )
    
24.     )
    
25.   )
    
26. ;;;;;;;;;;;;;;
    
27. (defun fast (l a / b c)
    
28.   (while l
    
29.     (if        (= a (car l))
    
30.       (progn (if b
    
31.                (setq c (cons (reverse b) c)
    
32.                      b nil
    
33.                )
    
34.              )
    
35.              (setq b (cons (car l) b)
    
36.                    l (cdr l)
    
37.              )
    
38.              (while (and l (/= a (car l)))
    
39.                (setq b (cons (car l) b)
    
40.                      l (cdr l)
    
41.                )
    
42.              )
    
43.              (setq c (cons (reverse b) c)
    
44.                    b nil
    
45.              )
    
46.       )
    
47.       (progn (setq b (cons (car l) b)
    
48.                    l (cdr l)
    
49.              )
    
50.       )
    
51.     )
    
52.   )
    
53.   (if b
    
54.     (setq c (cons (reverse b) c)
    
55.           b nil
    
56.     )
    
57.   )
    
58.   (reverse c)
    
59. );;测试 (f '(2 1 3 4 5 6 2 7 8 9 2 11 13 14 2)  2) ==>'((2 1 3 4 5 6) (2 7 8 9) (2 11 13 14) (2))  
    
60. 
    
61. (defun gxl-cs:gcd (inspt height  scale  / pt  pt1 blkdef obj)
    
62.   (setvar "CMDECHO" 0)
    
63.   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")
    
64.   (if height
    
65.     (setq height (rtos height 2 3))
    
66.     (setq height "")
    
67.   )
    
68. 
    
69.   
    
70.   (regapp "SOUTH")
    
71.   ;;;检查字体 "HZ" 是否存在
    
72.   (if (not (tblobjname "style" "HZ"))
    
73.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    
74.   )
    
75.   ;;;检查是否存在高程点图块定义
    
76.   (if (not (tblobjname "block" "GC200"))
    
77.     (progn
    
78.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
    
79.       (setq obj
    
80.         (vla-AddPolyline
    
81.            blkdef
    
82.            (vlax-make-variant
    
83.               (vlax-safearray-fill
    
84.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
    
85.                  '(-0.2 0 0 0.2 0 0)
    
86.               )
    
87.            )
    
88.         )
    
89.       )
    
90.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
    
91.       (vla-put-Closed obj :vlax-true)
    
92.       (vla-put-ConstantWidth obj 0.4)
    
93.     )
    
94.   )
    
95.   ;;;插入块
    
96.   (entmake (list
    
97.              '(0 . "INSERT")
    
98.              '(100 . "AcDbEntity")
    
99.              '(100 . "AcDbBlockReference")
    
100.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
     
101.               (cons 2 "GC200")
     
102.               (cons 10 inspt)
     
103.               (cons 41 scale)
     
104.               (cons 42 scale)
     
105.               (cons 43 scale)
     
106.               '(-3 ("SOUTH" (1000 . "202101")))
     
107.            )
     
108.   )
     
109.   ;;;插入属性
     
110.   (entmake (list
     
111.              '(0 . "ATTRIB")
     
112.              '(100 . "AcDbEntity")
     
113.              '(100 . "AcDbText")
     
114.               (cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
     
115.               (cons 40 (* 2.0 scale))
     
116.               (cons 50 0)
     
117.                (cons 62 3)
     
118.               (cons 41 0.8)
     
119.               (cons 51 0)
     
120.               (cons 1 height)
     
121.               (cons 7 "宋体")
     
122.               (cons 72 0)
     
123.               (cons 11 pt)
     
124.               '(100 . "AcDbAttribute")
     
125.               (cons 2 "height")
     
126.               (cons 70  0)
     
127.               (cons 74 2)
     
128.            )
     
129.    )
     
130. ;;;;;;;;;;;;;;;;;;;;;;;
     
131. ;;;插入属性
     
132.   
     
133.   
     
134.    ;;;结束标志
     
135.    (entmake '((0 . "SEQEND")))
     
136.    (princ)
     
137. )
     
138. 
     
139. 
     
140. ;;;;;;;;===========================================
     
141. (defun _List:FromFile        (fn / f l ll)
     
142.     (if        (setq f (open (findfile fn) "r"))
     
143.       (progn
     
144.         (while (setq l (read-line f))
     
145.          (IF (= (ASCII l)98)  (progn   (setq l (append (list l) (list"k") ))(setq ll (append l ll ))   )  ;;(append (list "回车 \n") (list l))
     
146.      (setq ll (cons l  ll ) )
     
147.      )
     
148.    
     
149.          
     
150.         )
     
151.         (close f)
     
152.       )
     
153.     )
     
154.     ( reverse(cdr(reverse (append (list"k") ll) ))  ) ;(reverse(reverse ll))
     
155. 
     
156.   )
     
157. ;;;;;;;;;;;;;;;
     
158. (defun c:dmsjgcd ( / en a  obj fl lst pzx blc scale  pt0 Perpt LST1 ang bb len height pt1)
     
159. (setq en (entsel "\n选择道路中心线: ") )
     
160.   (setq obj (vlax-ename->vla-object (car en)))
     
161.   (if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))
     
162.   
     
163.   (setq blc (getint "\n请输入比例尺1:"))
     
164.   (setvar 'userr1 blc);设置比例尺
     
165.   ;(setq zg (* 0.002 blc));字高
     
166.   (setq scale (* 0.001 blc));缩放比例
     
167.    
     
168. (setq fl (getfiled "Select Log file请选取南方CASS横断面数据文件：" "" "hdm" 8))
     
169. (setq lst         (_List:FromFile fl) )
     
170. (setq pzx (mapcar '(lambda (x)(reverse(cdr x)))   (fast lst "k")) ) ; (print pzx)
     
171. 
     
172. (foreach x pzx
     
173. (setq bb (distof (car(cdr (String:Split (car x) ",")) )))   ;(print (- bb a))
     
174.   
     
175. (setq pt0 (vlax-curve-getPointAtDist obj (- bb a)) )  ;(print pt0)
     
176.   
     
177.   (setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)
     
178.     LST1   (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))
     
179.     ANG   (atan (/ (cadr LST1) (car LST1)))
     
180.     ;pt1   (polar pt0 (+ ANG (* 0.5 pi)) len)
     
181.     ;pt2   (polar pt0 (- ANG (* 0.5 pi)) len)
     
182.      ;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))
     
183.    )
     
184.   
     
185. 
     
186. (foreach y (cdr x)
     
187.   (setq len   (distof (car (String:Split y ","))))   ;(print len)  ;
     
188.   (setq pt1 (polar pt0 (- ANG (* 0.5 pi)) len) )  ;(print pt1)      
     
189.   (setq height (distof (car(cdr (String:Split y ","))) )) ;(print height)   ;;;;   (distof(car (cdr (String:Split (car  (cdr (car pzx))) ",")) ))
     
190. 
     
191.   (  gxl-cs:gcd  (list (car pt1)(cadr pt1)height) height  scale)
     
192.   
     
193.   )
     
194. 
     
195. 
     
196.   
     
197.   )
     
198.   
     
199. 
     
200. ;(cdr (String:Split "begin,1250" ","))  (mapcar 'distof (cdr (String:Split "begin,1250" ",")))  (mapcar 'distof (car (String:Split "25639,1250" ",")))
     
201. 
     
202. 
     
203. )

(gc)<br /> (vl-load-com)<br /> ;;;;;;;;;;;;;;;;;;;<br /> (defun str->pt (str)<br />     (XD::Pnt:SetZ<br />       (mapcar 'distof (cdr (String:Split str ",")))<br />       0.<br />     )<br />   )<br /> <br /> ;;;;;;;;;;;<br /> (defun String:Split (str delimiter / post strlst stl)<br />     (if        str<br />       (progn<br />         (setq stl (strlen delimiter))<br />         (while (vl-string-search delimiter str)<br />           (setq        post   (vl-string-search delimiter str)<br />                 strlst (cons (substr str 1 post) strlst)<br />                 str    (substr str (+ 1 post stl))<br />           )<br />         )<br />         (reverse (vl-remove "" (cons str strlst)))<br />       )<br />     )<br />   )<br /> ;;;;;;;;;;;;;;<br /> (defun fast (l a / b c)<br />   (while l<br />     (if        (= a (car l))<br />       (progn (if b<br />                (setq c (cons (reverse b) c)<br />                      b nil<br />                )<br />              )<br />              (setq b (cons (car l) b)<br />                    l (cdr l)<br />              )<br />              (while (and l (/= a (car l)))<br />                (setq b (cons (car l) b)<br />                      l (cdr l)<br />                )<br />              )<br />              (setq c (cons (reverse b) c)<br />                    b nil<br />              )<br />       )<br />       (progn (setq b (cons (car l) b)<br />                    l (cdr l)<br />              )<br />       )<br />     )<br />   )<br />   (if b<br />     (setq c (cons (reverse b) c)<br />           b nil<br />     )<br />   )<br />   (reverse c)<br /> );;测试 (f '(2 1 3 4 5 6 2 7 8 9 2 11 13 14 2)  2) ==>'((2 1 3 4 5 6) (2 7 8 9) (2 11 13 14) (2))  <br /> <br /> (defun gxl-cs:gcd (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" "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 />               '(-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) (* 1.8 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 "宋体")<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 /> (defun _List:FromFile        (fn / f l ll)<br />     (if        (setq f (open (findfile fn) "r"))<br />       (progn<br />         (while (setq l (read-line f))<br />          (IF (= (ASCII l)98)  (progn   (setq l (append (list l) (list"k") ))(setq ll (append l ll ))   )  ;;(append (list "回车 \n") (list l))<br />      (setq ll (cons l  ll ) )<br />      ) <br />     <br />           <br />         )<br />         (close f)<br />       )<br />     )<br />     ( reverse(cdr(reverse (append (list"k") ll) ))  ) ;(reverse(reverse ll))<br /> <br />   )<br /> ;;;;;;;;;;;;;;;<br /> (defun c:dmsjgcd ( / en a  obj fl lst pzx blc scale  pt0 Perpt LST1 ang bb len height pt1)<br /> (setq en (entsel "\n选择道路中心线: ") )<br />   (setq obj (vlax-ename->vla-object (car en)))<br />   (if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))<br />   <br />   (setq blc (getint "\n请输入比例尺1:"))<br />   (setvar 'userr1 blc);设置比例尺<br />   ;(setq zg (* 0.002 blc));字高<br />   (setq scale (* 0.001 blc));缩放比例<br />     <br /> (setq fl (getfiled "Select Log file请选取南方CASS横断面数据文件：" "" "hdm" 8))<br /> (setq lst         (_List:FromFile fl) )<br /> (setq pzx (mapcar '(lambda (x)(reverse(cdr x)))   (fast lst "k")) ) ; (print pzx)<br /> <br /> (foreach x pzx<br /> (setq bb (distof (car(cdr (String:Split (car x) ",")) )))   ;(print (- bb a))<br />   <br /> (setq pt0 (vlax-curve-getPointAtDist obj (- bb a)) )  ;(print pt0)<br />   <br />   (setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)<br />     LST1   (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))<br />     ANG   (atan (/ (cadr LST1) (car LST1)))<br />     ;pt1   (polar pt0 (+ ANG (* 0.5 pi)) len)<br />     ;pt2   (polar pt0 (- ANG (* 0.5 pi)) len)<br />      ;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))<br />    )<br />   <br /> <br /> (foreach y (cdr x)<br />   (setq len   (distof (car (String:Split y ","))))   ;(print len)  ;<br />   (setq pt1 (polar pt0 (- ANG (* 0.5 pi)) len) )  ;(print pt1)      <br />   (setq height (distof (car(cdr (String:Split y ","))) )) ;(print height)   ;;;;   (distof(car (cdr (String:Split (car  (cdr (car pzx))) ",")) ))<br /> <br />   (  gxl-cs:gcd  (list (car pt1)(cadr pt1)height) height  scale)<br />   <br />   )<br /> <br /> <br />   <br />   )<br />   <br /> <br /> ;(cdr (String:Split "begin,1250" ","))  (mapcar 'distof (cdr (String:Split "begin,1250" ",")))  (mapcar 'distof (car (String:Split "25639,1250" ",")))<br /> <br /> <br /> )

测试数据：存盘为**.hdm
begin,1020
-45,12
-40,15
-35,22
-30,15
-25,3
-15,10
-8,6
0,9
3,15
16,22
26,16
33,14
45,22
begin,1040
-50,23
-45,36
-40,15
-35,20
-30,15
-25,16
-20,18
-17,22
-10,16
0,22
8,6
15,2
19,12
25,14
31,21
40,26
48,33
50,30

树櫴希德

这个应该用的比较少吧

树櫴希德

1. (defun c:tt ()
   
2.   ;; tt(圆心标注)
   
3.   (setq i -1)
   
4.   (if (setq ss (ssget '((0 . "circle"))))
   
5.     (while (setq s1 (ssname ss (setq i (1+ i))))
   
6.       (setq rr (cdr (assoc 40 (entget s1))))
   
7.       (setvar "dimcen" (* rr 1.1))
   
8.       (command "dimcenter" (list s1 '(0 0)))
   
9.     )
   
10.   )
    
11.   (princ)
    
12. )

(defun c:tt ()<br />   ;; tt(圆心标注)<br />   (setq i -1)<br />   (if (setq ss (ssget '((0 . "circle"))))<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (setq rr (cdr (assoc 40 (entget s1))))<br />       (setvar "dimcen" (* rr 1.1))<br />       (command "dimcenter" (list s1 '(0 0)))<br />     )<br />   )<br />   (princ)<br /> )

树櫴希德

横断面标高偏距标注

1. ;;;;;;;;;;;;;
   
2. (defun mkgcd (inspt height height-1 scale  / pt  pt1 blkdef obj)
   
3. (gc)  (vl-load-com)
   
4.   (setvar "CMDECHO" 0)
   
5.   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")
   
6. (cond ((= (type height) REAL) (setq height (rtos height 2 3))  )
   
7.      ((= (type height) STR) (setq height height)  )
   
8. 
   
9. ((= (type height-1) REAL) (setq height-1 (rtos height-1 2 3))  )
   
10.      ((= (type height-1) STR) (setq height-1 height-1)  )
    
11.       
    
12.   )
    
13.   ;;;;-------------
    
14. ; (if height     (setq height (rtos height 2 3))      (setq height  "")   )
    
15. ;(if height-1     (setq height-1 (rtos height-1 2 3))     (setq height-1 "")   )
    
16.   ;;;;-------------
    
17.   (regapp "SOUTH")
    
18.   ;;;检查字体 "HZ" 是否存在
    
19.   (if (not (tblobjname "style" "HZ"))
    
20.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
    
21.   )
    
22. (if (not (tblobjname "style" "宋体"))
    
23.     (command "-style" "宋体" "宋体" 0 1 0 "" "" "")
    
24.   )
    
25. 
    
26.   
    
27.   ;;;检查是否存在高程点图块定义
    
28.   (if (not (tblobjname "block" "GC200"))
    
29.     (progn
    
30.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
    
31.       (setq obj
    
32.         (vla-AddPolyline
    
33.            blkdef
    
34.            (vlax-make-variant
    
35.               (vlax-safearray-fill
    
36.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
    
37.                  '(-0.2 0 0 0.2 0 0)
    
38.               )
    
39.            )
    
40.         )
    
41.       )
    
42.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
    
43.       (vla-put-Closed obj :vlax-true)
    
44.       (vla-put-ConstantWidth obj 0.4)
    
45.     )
    
46.   )
    
47.   ;;;插入块
    
48.   (entmake (list
    
49.              '(0 . "INSERT")
    
50.              '(100 . "AcDbEntity")
    
51.              '(100 . "AcDbBlockReference")
    
52.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
    
53.               (cons 2 "GC200")
    
54.               (cons 10 inspt)
    
55.               (cons 41 scale)
    
56.               (cons 42 scale)
    
57.               (cons 43 scale)
    
58.               '(-3 ("SOUTH" (1000 . "84848412")))
    
59.            )
    
60.   )
    
61.   ;;;插入属性
    
62.   (entmake (list
    
63.              '(0 . "ATTRIB")
    
64.              '(100 . "AcDbEntity")
    
65.              '(100 . "AcDbText")
    
66.               (cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
    
67.               (cons 40 (* 2.0 scale))
    
68.               (cons 50 0)
    
69.                (cons 62 3)
    
70.               (cons 41 0.8)
    
71.               (cons 51 0)
    
72.               (cons 1 height)
    
73.               (cons 7 "宋体")
    
74.               (cons 72 0)
    
75.               (cons 11 pt)
    
76.               '(100 . "AcDbAttribute")
    
77.               (cons 2 "height")
    
78.               (cons 70  0)
    
79.               (cons 74 2)
    
80.            )
    
81.    )
    
82. ;;;;;;;;;;;;;;;;;;;;;;;
    
83.   (entmake (list
    
84.              '(0 . "ATTRIB")
    
85.              '(100 . "AcDbEntity")
    
86.              '(100 . "AcDbText")
    
87.               (cons 10 (setq pt1 (polar inspt (* 0.5 PI) (* 1.8 scale))))
    
88.               (cons 40 (* 2.0 scale))
    
89.               (cons 50 0)
    
90.                (cons 62 3)
    
91.               (cons 41 0.8)
    
92.               (cons 51 0)
    
93.               (cons 1 height-1)
    
94.               (cons 7 "宋体")
    
95.               (cons 72 0)
    
96.               (cons 11 pt1)
    
97.               '(100 . "AcDbAttribute")
    
98.               (cons 2 "height-1")
    
99.               (cons 70  0)
    
100.               (cons 74 2)
     
101.            )
     
102.    )
     
103. ;;;插入属性
     
104.   
     
105.   
     
106.    ;;;结束标志
     
107.    (entmake '((0 . "SEQEND")))
     
108.    (princ)
     
109. )
     
110. ;;;;;;;;;;;
     
111. 
     
112. 
     
113. (defun c:dmbzbg (  / osmode_bak scale scale1 zh hxbl zxbl midxy midx midy ssa s h i f pt1 bzx bzy y)
     
114. 
     
115. (vl-load-com) (gc)
     
116. (setvar "cmdecho" 0)
     
117.      (setq osmode_bak(getvar "osmode"))
     
118.      (setvar "osmode" 1)
     
119.      (command "layer" "M" "dmbz" "C" "7" "" "LT" "CONTINUOUS" "" "")
     
120.      (princ "标注比例尺:<1:")
     
121.      (princ scale)
     
122.      (princ ">")
     
123.      (setq scale1 (getreal))
     
124.      (if (not (null scale1)) (setq scale scale1))
     
125.      (setq zh (/ (* 1.5 scale) 1000))
     
126.   
     
127. (setq hxbl (getint "\n请输入断面横向比例 1 :"))
     
128.   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
     
129.      (setvar "luprec" 4)  
     
130.        (setq midxy(getpoint "\n请选择断面的中点:"))
     
131.        (setq midx(nth 0 midxy))
     
132.        (setq midy(nth 1 midxy))
     
133.        (setq midgc(getreal "\n请输入断面的中点高程:"))
     
134. 
     
135. 
     
136.   (while  (setq y (getpoint "\n请选择断面上需要标注坐标偏距的点:"))
     
137. 
     
138.        ;;;;
     
139. 
     
140.     (setq bzx(nth 0 y))
     
141.               (setq bzy(nth 1 y))
     
142.               (setq s(strcat "偏距：" (rtos    (* (- bzx midx ) (/ hxbl 1000.000))      2 3)))
     
143.               (setq h(strcat "高程：" (rtos (+ midgc  (*(- bzy midy) (/ zxbl 1000.000) )   ) 2 3)))
     
144.     ;;;;;
     
145.    (mkgcd y s h zh)
     
146.     )
     
147.    
     
148.   (princ)
     
149. )

;;;;;;;;;;;;;<br /> (defun mkgcd (inspt height height-1 scale  / pt  pt1 blkdef obj)<br /> (gc)  (vl-load-com)<br />   (setvar "CMDECHO" 0)<br />   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")<br /> (cond ((= (type height) REAL) (setq height (rtos height 2 3))  )<br />      ((= (type height) STR) (setq height height)  )<br /> <br /> ((= (type height-1) REAL) (setq height-1 (rtos height-1 2 3))  )<br />      ((= (type height-1) STR) (setq height-1 height-1)  )<br />       <br />   )<br />   ;;;;-------------<br /> ; (if height     (setq height (rtos height 2 3))      (setq height  "")   )<br /> ;(if height-1     (setq height-1 (rtos height-1 2 3))     (setq height-1 "")   )<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 /> (if (not (tblobjname "style" "宋体"))<br />     (command "-style" "宋体" "宋体" 0 1 0 "" "" "")<br />   )<br /> <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 />               '(-3 ("SOUTH" (1000 . "84848412")))<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) (* 1.8 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 "宋体")<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 (list<br />              '(0 . "ATTRIB")<br />              '(100 . "AcDbEntity")<br />              '(100 . "AcDbText")<br />               (cons 10 (setq pt1 (polar inspt (* 0.5 PI) (* 1.8 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-1)<br />               (cons 7 "宋体")<br />               (cons 72 0)<br />               (cons 11 pt1)<br />               '(100 . "AcDbAttribute")<br />               (cons 2 "height-1")<br />               (cons 70  0)<br />               (cons 74 2)<br />            )<br />    )<br /> ;;;插入属性<br />   <br />   <br />    ;;;结束标志<br />    (entmake '((0 . "SEQEND")))<br />    (princ)<br /> )<br /> ;;;;;;;;;;;<br /> <br /> <br /> (defun c:dmbzbg (  / osmode_bak scale scale1 zh hxbl zxbl midxy midx midy ssa s h i f pt1 bzx bzy y)<br /> <br /> (vl-load-com) (gc)<br /> (setvar "cmdecho" 0)<br />      (setq osmode_bak(getvar "osmode"))<br />      (setvar "osmode" 1)<br />      (command "layer" "M" "dmbz" "C" "7" "" "LT" "CONTINUOUS" "" "")<br />      (princ "标注比例尺:<1:")<br />      (princ scale)<br />      (princ ">")<br />      (setq scale1 (getreal))<br />      (if (not (null scale1)) (setq scale scale1))<br />      (setq zh (/ (* 1.5 scale) 1000))<br />   <br /> (setq hxbl (getint "\n请输入断面横向比例 1 :"))<br />   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))<br />      (setvar "luprec" 4)  <br />        (setq midxy(getpoint "\n请选择断面的中点:"))<br />        (setq midx(nth 0 midxy))<br />        (setq midy(nth 1 midxy))<br />        (setq midgc(getreal "\n请输入断面的中点高程:"))<br /> <br /> <br />   (while  (setq y (getpoint "\n请选择断面上需要标注坐标偏距的点:"))<br /> <br />        ;;;;<br /> <br />     (setq bzx(nth 0 y))<br />               (setq bzy(nth 1 y))<br />               (setq s(strcat "偏距：" (rtos    (* (- bzx midx ) (/ hxbl 1000.000))      2 3)))<br />               (setq h(strcat "高程：" (rtos (+ midgc  (*(- bzy midy) (/ zxbl 1000.000) )   ) 2 3)))<br />     ;;;;;<br />    (mkgcd y s h zh)<br />     )<br />    <br />   (princ)<br /> )

dwjb

yuanziyou

就楼主还活跃在测绘板块

yxh1202

请问你这两个工具有啥区别吗。我在研究已知起点距，绝对高程。想返回XYZ

树櫴希德

1. (gc)
   
2. (vl-load-com)
   
3. 
   
4. (defun gxl-cs:gcd (inspt height  scale  / pt  pt1 blkdef obj)
   
5.   (setvar "CMDECHO" 0)
   
6.   (command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" ""  "")
   
7.   (if height
   
8.     (setq height (rtos height 2 3))
   
9.     (setq height "")
   
10.   )
    
11. 
    
12.   
    
13.   (regapp "SOUTH")
    
14.   ;;;检查字体 "HZ" 是否存在
    
15.   (if (not (tblobjname "style" "HZ"))
    
16.     (command "style" "HZ" "txt.shx,hztxt.shx" 0 1 0 "" "" "")
    
17.   )
    
18.   ;;;检查是否存在高程点图块定义
    
19.   (if (not (tblobjname "block" "GC200"))
    
20.     (progn
    
21.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
    
22.       (setq obj
    
23.         (vla-AddPolyline
    
24.            blkdef
    
25.            (vlax-make-variant
    
26.               (vlax-safearray-fill
    
27.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
    
28.                  '(-0.2 0 0 0.2 0 0)
    
29.               )
    
30.            )
    
31.         )
    
32.       )
    
33.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
    
34.       (vla-put-Closed obj :vlax-true)
    
35.       (vla-put-ConstantWidth obj 0.4)
    
36.     )
    
37.   )
    
38.   ;;;插入块
    
39.   (entmake (list
    
40.              '(0 . "INSERT")
    
41.              '(100 . "AcDbEntity")
    
42.              '(100 . "AcDbBlockReference")
    
43.              '(66 . 1);;;属性跟随标志,1跟随，0不跟随
    
44.               (cons 2 "GC200")
    
45.               (cons 10 inspt)
    
46.               (cons 41 scale)
    
47.               (cons 42 scale)
    
48.               (cons 43 scale)
    
49.               '(-3 ("SOUTH" (1000 . "202101")))
    
50.            )
    
51.   )
    
52.   ;;;插入属性
    
53.   (entmake (list
    
54.              '(0 . "ATTRIB")
    
55.              '(100 . "AcDbEntity")
    
56.              '(100 . "AcDbText")
    
57.               (cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
    
58.               (cons 40 (* 2.0 scale))
    
59.               (cons 50 0)
    
60.                (cons 62 3)
    
61.               (cons 41 0.8)
    
62.               (cons 51 0)
    
63.               (cons 1 height)
    
64.               (cons 7 "HZ")
    
65.               (cons 72 0)
    
66.               (cons 11 pt)
    
67.               '(100 . "AcDbAttribute")
    
68.               (cons 2 "height")
    
69.               (cons 70  0)
    
70.               (cons 74 2)
    
71.            )
    
72.    )
    
73. ;;;;;;;;;;;;;;;;;;;;;;;
    
74. ;;;插入属性
    
75.   
    
76.   
    
77.    ;;;结束标志
    
78.    (entmake '((0 . "SEQEND")))
    
79.    (princ)
    
80. )
    
81. 
    
82. 
    
83. 
    
84. 
    
85. ;;;;
    
86. (defun vxs(e / p a b n ob q et d d1 en et)
    
87.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
    
88.     (cond((="LWPOLYLINE"et)
    
89.     (repeat(length a)(setq b (nth n a) n (+ n 1))
    
90.       (if (= 10 (car b))(progn
    
91.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
    
92.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
    
93.           (setq p (list q)))))))
    
94.    ((="POLYLINE"et)
    
95.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    
96.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
    
97.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
    
98.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
    
99.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    
100.     (setq p(reverse p))))P)
     
101. ;;;;;;;;;;
     
102. ;;;;;;;;;;;;;;;
     
103. (defun c:dmzgc ( / en a bbb  obj fl lst pzx blc scale  pt0 Perpt LST1 ang bb len height pt1 en1 zbb xzbb pta ptaa xxzbb zzbg );
     
104. (prompt "\n dmzgc")
     
105.   (setq en (entsel "\n选择道路中心线: ") )
     
106.   (setq obj (vlax-ename->vla-object (car en)))
     
107.   (if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))
     
108.   
     
109.   (setq blc (getint "\n请输入比例尺1:"))
     
110.   (setvar 'userr1 blc);设置比例尺
     
111.   ;(setq zg (* 0.002 blc));字高
     
112.   (setq scale (* 0.001 blc));缩放比例
     
113.    
     
114. 
     
115. (setq hxbl (getint "\n请输入断面横向比例 1 :"))
     
116.   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
     
117. 
     
118. 
     
119.   (while (setq en1 (car(entsel "\n选择道路横断面线（从左至右画）: ") ))
     
120.     (setq bbb (getreal "\n请输入断面桩号<0>:"))
     
121.     (setq pt0 (vlax-curve-getPointAtDist obj (- bbb a)) )  ;(print pt0)
     
122.   (setq pta (getpoint"\n请点击断面中桩位置(标高零点):" ))
     
123. (setq zzbg (getreal "\n请输入中桩标高："))
     
124.    
     
125.   (setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)
     
126.     LST1   (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))
     
127.     ANG   (atan (/ (cadr LST1) (car LST1)))
     
128.     ;pt1   (polar pt0 (+ ANG (* 0.5 pi)) len)
     
129.     ;pt2   (polar pt0 (- ANG (* 0.5 pi)) len)
     
130.      ;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))
     
131.    )
     
132.     (setq ptaa (list (* (car pta)(/ hxbl 1000.000) ) (* (cadr pta)(/ zxbl 1000.000) )              ))
     
133.   
     
134. (setq zbb (vxs en1))
     
135.   (setq xzbb  (mapcar          '(lambda (a ) (list   (* (car a)(/ hxbl 1000.000) )  (* (cadr a)(/ zxbl 1000.000) )     )
     
136.           )
     
137.     zbb)
     
138. 
     
139.    )
     
140.    
     
141. (setq xxzbb  (mapcar          '(lambda (a ) (list   (- (car a)(car ptaa) )  (+(- (cadr a)(cadr ptaa) ) zzbg)    )
     
142.           )
     
143.     xzbb)
     
144. 
     
145.    )
     
146. 
     
147. (foreach n xxzbb
     
148. 
     
149. (setq pt1 (polar pt0 (- ANG (* 0.5 pi)) (car n)) )  ;(print pt1)
     
150. (setq height (cadr n)) ;(print height)
     
151.   (gxl-cs:gcd  (list (car pt1)(cadr pt1)height) height  scale)
     
152.   )
     
153.     (prompt "\n 请选择下一断面")
     
154.    
     
155.    
     
156.     )
     
157. 
     
158. ;(cdr (String:Split "begin,1250" ","))  (mapcar 'distof (cdr (String:Split "begin,1250" ",")))  (mapcar 'distof (car (String:Split "25639,1250" ",")))
     
159. 
     
160. (princ)
     
161. )

(gc)<br /> (vl-load-com)<br /> <br /> (defun gxl-cs:gcd (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" "txt.shx,hztxt.shx" 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 />               '(-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) (* 1.8 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 /> (defun vxs(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="POLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> ;;;;;;;;;;<br /> ;;;;;;;;;;;;;;;<br /> (defun c:dmzgc ( / en a bbb  obj fl lst pzx blc scale  pt0 Perpt LST1 ang bb len height pt1 en1 zbb xzbb pta ptaa xxzbb zzbg );<br /> (prompt "\n dmzgc")<br />   (setq en (entsel "\n选择道路中心线: ") )<br />   (setq obj (vlax-ename->vla-object (car en)))<br />   (if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))<br />   <br />   (setq blc (getint "\n请输入比例尺1:"))<br />   (setvar 'userr1 blc);设置比例尺<br />   ;(setq zg (* 0.002 blc));字高<br />   (setq scale (* 0.001 blc));缩放比例<br />     <br /> <br /> (setq hxbl (getint "\n请输入断面横向比例 1 :"))<br />   (setq zxbl (getint "\n请输入断面纵向比例 1 :"))<br /> <br /> <br />   (while (setq en1 (car(entsel "\n选择道路横断面线（从左至右画）: ") ))<br />     (setq bbb (getreal "\n请输入断面桩号<0>:"))<br />     (setq pt0 (vlax-curve-getPointAtDist obj (- bbb a)) )  ;(print pt0)<br />   (setq pta (getpoint"\n请点击断面中桩位置(标高零点):" ))<br /> (setq zzbg (getreal "\n请输入中桩标高："))<br />     <br />   (setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)<br />     LST1   (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))<br />     ANG   (atan (/ (cadr LST1) (car LST1)))<br />     ;pt1   (polar pt0 (+ ANG (* 0.5 pi)) len)<br />     ;pt2   (polar pt0 (- ANG (* 0.5 pi)) len)<br />      ;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))<br />    )<br />     (setq ptaa (list (* (car pta)(/ hxbl 1000.000) ) (* (cadr pta)(/ zxbl 1000.000) )              ))<br />   <br /> (setq zbb (vxs en1))<br />   (setq xzbb  (mapcar          '(lambda (a ) (list   (* (car a)(/ hxbl 1000.000) )  (* (cadr a)(/ zxbl 1000.000) )     )<br />           )<br />     zbb)<br /> <br />    )<br />     <br /> (setq xxzbb  (mapcar          '(lambda (a ) (list   (- (car a)(car ptaa) )  (+(- (cadr a)(cadr ptaa) ) zzbg)    )<br />           )<br />     xzbb)<br /> <br />    )<br /> <br /> (foreach n xxzbb<br /> <br /> (setq pt1 (polar pt0 (- ANG (* 0.5 pi)) (car n)) )  ;(print pt1)<br /> (setq height (cadr n)) ;(print height)<br />   (gxl-cs:gcd  (list (car pt1)(cadr pt1)height) height  scale)<br />   )<br />     (prompt "\n 请选择下一断面")<br />     <br />    <br />     )<br /> <br /> ;(cdr (String:Split "begin,1250" ","))  (mapcar 'distof (cdr (String:Split "begin,1250" ",")))  (mapcar 'distof (car (String:Split "25639,1250" ",")))<br /> <br /> (princ)<br /> )

树櫴希德

forech换MAPCAR 不知道会不会快些

spring8801

请问横断面数据转高程我这怎么不能用？