cass横断面数据转高程
数不清大神们的函数 有GU版等(gc)
(vl-load-com)
;;;;;;;;;;;;;;;;;;;
(defun str->pt (str)
(XD::Pnt:SetZ
(mapcar 'distof (cdr (String:Split str ",")))
0.
)
)
;;;;;;;;;;;
(defun String:Split (str delimiter / post strlst stl)
(if str
(progn
(setq stl (strlen delimiter))
(while (vl-string-search delimiter str)
(setq post (vl-string-search delimiter str)
strlst (cons (substr str 1 post) strlst)
str (substr str (+ 1 post stl))
)
)
(reverse (vl-remove "" (cons str strlst)))
)
)
)
;;;;;;;;;;;;;;
(defun fast (l a / b c)
(while l
(if (= a (car l))
(progn (if b
(setq c (cons (reverse b) c)
b nil
)
)
(setq b (cons (car l) b)
l (cdr l)
)
(while (and l (/= a (car l)))
(setq b (cons (car l) b)
l (cdr l)
)
)
(setq c (cons (reverse b) c)
b nil
)
)
(progn (setq b (cons (car l) b)
l (cdr l)
)
)
)
)
(if b
(setq c (cons (reverse b) c)
b nil
)
)
(reverse c)
);;测试 (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))
(defun gxl-cs:gcd (inspt heightscale/ ptpt1 blkdef obj)
(setvar "CMDECHO" 0)
(command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" """")
(if height
(setq height (rtos height 2 3))
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
'(-3 ("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 3)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "宋体")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 700)
(cons 74 2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;
;;;插入属性
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;===========================================
(defun _List:FromFile (fn / f l ll)
(if (setq f (open (findfile fn) "r"))
(progn
(while (setq l (read-line f))
(IF (= (ASCII l)98)(progn (setq l (append (list l) (list"k") ))(setq ll (append l ll )) );;(append (list "回车 \n") (list l))
(setq ll (cons lll ) )
)
)
(close f)
)
)
( reverse(cdr(reverse (append (list"k") ll) ))) ;(reverse(reverse ll))
)
;;;;;;;;;;;;;;;
(defun c:dmsjgcd ( / en aobj fl lst pzx blc scalept0 Perpt LST1 ang bb len height pt1)
(setq en (entsel "\n选择道路中心线: ") )
(setq obj (vlax-ename->vla-object (car en)))
(if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))
(setq blc (getint "\n请输入比例尺1:"))
(setvar 'userr1 blc);设置比例尺
;(setq zg (* 0.002 blc));字高
(setq scale (* 0.001 blc));缩放比例
(setq fl (getfiled "Select Log file请选取南方CASS横断面数据文件：" "" "hdm" 8))
(setq lst (_List:FromFile fl) )
(setq pzx (mapcar '(lambda (x)(reverse(cdr x))) (fast lst "k")) ) ; (print pzx)
(foreach x pzx
(setq bb (distof (car(cdr (String:Split (car x) ",")) ))) ;(print (- bb a))
(setq pt0 (vlax-curve-getPointAtDist obj (- bb a)) );(print pt0)
(setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)
LST1 (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))
ANG (atan (/ (cadr LST1) (car LST1)))
;pt1 (polar pt0 (+ ANG (* 0.5 pi)) len)
;pt2 (polar pt0 (- ANG (* 0.5 pi)) len)
;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))
)
(foreach y (cdr x)
(setq len (distof (car (String:Split y ",")))) ;(print len);
(setq pt1 (polar pt0 (- ANG (* 0.5 pi)) len) );(print pt1)
(setq height (distof (car(cdr (String:Split y ","))) )) ;(print height) ;;;; (distof(car (cdr (String:Split (car(cdr (car pzx))) ",")) ))
(gxl-cs:gcd(list (car pt1)(cadr pt1)height) heightscale)
)
)
;(cdr (String:Split "begin,1250" ","))(mapcar 'distof (cdr (String:Split "begin,1250" ",")))(mapcar 'distof (car (String:Split "25639,1250" ",")))
)
测试数据：存盘为**.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
本帖最后由 树櫴希德 于 2019-4-26 18:42 编辑
这个应该用的比较少吧
(defun c:tt ()
;; tt(圆心标注)
(setq i -1)
(if (setq ss (ssget '((0 . "circle"))))
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq rr (cdr (assoc 40 (entget s1))))
(setvar "dimcen" (* rr 1.1))
(command "dimcenter" (list s1 '(0 0)))
)
)
(princ)
) 横断面标高偏距标注
;;;;;;;;;;;;;
(defun mkgcd (inspt height height-1 scale/ ptpt1 blkdef obj)
(gc)(vl-load-com)
(setvar "CMDECHO" 0)
(command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" """")
(cond ((= (type height) REAL) (setq height (rtos height 2 3)))
((= (type height) STR) (setq height height))
((= (type height-1) REAL) (setq height-1 (rtos height-1 2 3)))
((= (type height-1) STR) (setq height-1 height-1))
)
;;;;-------------
; (if height (setq height (rtos height 2 3)) (setq height"") )
;(if height-1 (setq height-1 (rtos height-1 2 3)) (setq height-1 "") )
;;;;-------------
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
)
(if (not (tblobjname "style" "宋体"))
(command "-style" "宋体" "宋体" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
'(-3 ("SOUTH" (1000 . "84848412")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 3)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "宋体")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 700)
(cons 74 2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt1 (polar inspt (* 0.5 PI) (* 1.8 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 3)
(cons 41 0.8)
(cons 51 0)
(cons 1 height-1)
(cons 7 "宋体")
(cons 72 0)
(cons 11 pt1)
'(100 . "AcDbAttribute")
(cons 2 "height-1")
(cons 700)
(cons 74 2)
)
)
;;;插入属性
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;;;;
(defun c:dmbzbg (/ osmode_bak scale scale1 zh hxbl zxbl midxy midx midy ssa s h i f pt1 bzx bzy y)
(vl-load-com) (gc)
(setvar "cmdecho" 0)
(setq osmode_bak(getvar "osmode"))
(setvar "osmode" 1)
(command "layer" "M" "dmbz" "C" "7" "" "LT" "CONTINUOUS" "" "")
(princ "标注比例尺:<1:")
(princ scale)
(princ ">")
(setq scale1 (getreal))
(if (not (null scale1)) (setq scale scale1))
(setq zh (/ (* 1.5 scale) 1000))
(setq hxbl (getint "\n请输入断面横向比例 1 :"))
(setq zxbl (getint "\n请输入断面纵向比例 1 :"))
(setvar "luprec" 4)
(setq midxy(getpoint "\n请选择断面的中点:"))
(setq midx(nth 0 midxy))
(setq midy(nth 1 midxy))
(setq midgc(getreal "\n请输入断面的中点高程:"))
(while(setq y (getpoint "\n请选择断面上需要标注坐标偏距的点:"))
;;;;
(setq bzx(nth 0 y))
(setq bzy(nth 1 y))
(setq s(strcat "偏距：" (rtos (* (- bzx midx ) (/ hxbl 1000.000)) 2 3)))
(setq h(strcat "高程：" (rtos (+ midgc(*(- bzy midy) (/ zxbl 1000.000) ) ) 2 3)))
;;;;;
(mkgcd y s h zh)
)
(princ)
)
就楼主还活跃在测绘板块 请问你这两个工具有啥区别吗。我在研究已知起点距，绝对高程。想返回XYZ (gc)
(vl-load-com)
(defun gxl-cs:gcd (inspt heightscale/ ptpt1 blkdef obj)
(setvar "CMDECHO" 0)
(command "layer" "m" "检查高程点" "c" "1" "" "L" "CONTINUOUS" """")
(if height
(setq height (rtos height 2 3))
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "txt.shx,hztxt.shx" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
'(-3 ("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt (* -0.5 PI) (* 1.8 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 62 3)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 700)
(cons 74 2)
)
)
;;;;;;;;;;;;;;;;;;;;;;;
;;;插入属性
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;
(defun vxs(e / p a b n ob q et d d1 en et)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))))))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))))P)
;;;;;;;;;;
;;;;;;;;;;;;;;;
(defun c:dmzgc ( / en a bbbobj fl lst pzx blc scalept0 Perpt LST1 ang bb len height pt1 en1 zbb xzbb pta ptaa xxzbb zzbg );
(prompt "\n dmzgc")
(setq en (entsel "\n选择道路中心线: ") )
(setq obj (vlax-ename->vla-object (car en)))
(if (= nil (setq a (getreal "\n请输入起点桩号<0>:"))) (setq a 0))
(setq blc (getint "\n请输入比例尺1:"))
(setvar 'userr1 blc);设置比例尺
;(setq zg (* 0.002 blc));字高
(setq scale (* 0.001 blc));缩放比例
(setq hxbl (getint "\n请输入断面横向比例 1 :"))
(setq zxbl (getint "\n请输入断面纵向比例 1 :"))
(while (setq en1 (car(entsel "\n选择道路横断面线（从左至右画）: ") ))
(setq bbb (getreal "\n请输入断面桩号<0>:"))
(setq pt0 (vlax-curve-getPointAtDist obj (- bbb a)) );(print pt0)
(setq pta (getpoint"\n请点击断面中桩位置(标高零点):" ))
(setq zzbg (getreal "\n请输入中桩标高："))
(setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)
LST1 (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))
ANG (atan (/ (cadr LST1) (car LST1)))
;pt1 (polar pt0 (+ ANG (* 0.5 pi)) len)
;pt2 (polar pt0 (- ANG (* 0.5 pi)) len)
;此处就是你画出来的是水平线的原因，变量换个方向即可 (distof(car(cdr (String:Split "begin,1040" ",")) ) ) (distof (cdr (String:Split "begin,1040" ",")))
)
(setq ptaa (list (* (car pta)(/ hxbl 1000.000) ) (* (cadr pta)(/ zxbl 1000.000) ) ))
(setq zbb (vxs en1))
(setq xzbb(mapcar '(lambda (a ) (list (* (car a)(/ hxbl 1000.000) )(* (cadr a)(/ zxbl 1000.000) ) )
)
zbb)
)
(setq xxzbb(mapcar '(lambda (a ) (list (- (car a)(car ptaa) )(+(- (cadr a)(cadr ptaa) ) zzbg) )
)
xzbb)
)
(foreach n xxzbb
(setq pt1 (polar pt0 (- ANG (* 0.5 pi)) (car n)) );(print pt1)
(setq height (cadr n)) ;(print height)
(gxl-cs:gcd(list (car pt1)(cadr pt1)height) heightscale)
)
(prompt "\n 请选择下一断面")
)
;(cdr (String:Split "begin,1250" ","))(mapcar 'distof (cdr (String:Split "begin,1250" ",")))(mapcar 'distof (car (String:Split "25639,1250" ",")))
(princ)
)
forech换MAPCAR 不知道会不会快些
请问横断面数据转高程我这怎么不能用？
页:
[1]