本帖最后由 skg123 于 2014-8-26 20:35 编辑
做公路的同行常常需要标注公路的中桩号，本人结合自己的需要在别人的程序上修改了标注程序。
批量标注，可以按照要求的间距标注，首尾保留小数。将中桩坐标写入文本
 -
- ;By Zo Roo CGGC 基础公司
- ;By zo roo 葛洲坝基础公司
- ;2010-5-9 修改了小数保留位数（保留0位）
- ;2011-6-15修改了尾桩号小数位数（保留3位）；设置捕捉，标注线不乱连接，增加桩号步长设置。
- (terpri)
- (If (= (Tblsearch "layer" "道路桩号") nil)
- (Command "layer" "m" "道路桩号" "c" 7 "道路桩号" "")
- )
- (If (= (Tblsearch "layer" "道路中心线") nil)
- (Command "layer" "m" "道路中心线" "c" 1 "道路中心线" "")
- )
- (setq dq 0.0)
- (setq wf 1.0)
- (setq fx 1.0)
- (setq th 2.0)
- (setq zk 0.67)
- (Command "-style" "道路桩号" "仿宋_GB2312" "" zk "" "n" "n")
- (setq qszh 0.0)
- (setq qz "")
- (setq qmw 0)
- (vl-load-com)
- (prompt "\n批量标注桩号,加载命令:plbzzh,设置(SZ)。By 罗泽钢 葛洲坝基础公司")
- (defun c:plbzzh()
- (setvar "cmdecho" 0)
- (setq ff (open (getfiled "文件保存为" "c:/" "dat" 1) "a"))
- (bzzh)
- );修改于2012-01-11增加了将数据写入文本
- (defun bzzh()
- (setvar "cmdecho" 0)
- (setq os (getvar "osmode"))
- (setq FltLst '((0 . "LWPOLYLINE,POLYLINE,LINE,ARC")))
- (princ "\n\n\n\n 请先把预标注的曲线(多段线)连接在一起,如果已经连接好，回车跳过即可 ")
- (setq SelSet (cond ((ssget "_I" FltLst)) ((ssget FltLst))))
- (if (/= nil selset) (command "change" SelSet "" "p" "la" "道路中心线" ""))
- (if (/= nil selset)
- (if (> (sslength selset) 1)
- (command "_.PEDIT" "_M" SelSet "" "_Y" "_J" "_J" "_B" "0" "")
- )
- )
- (setq en (car (entsel "\n选择标注曲线:")))
- (while (= nil en)
- (setq en (car (entsel "\n选择标注曲线:")))
- )
- (if (vlax-curve-isClosed en)
- (progn
- (print "曲线为环路！请先打开个缺口！")
- (exit)
- )
- )
- (redraw en 3)
- (command "change" en "" "p" "la" "道路中心线" "")
- (setq qd (getpoint "\n选取已知点："))
- (while (not (vlax-curve-getDistAtPoint en qd))
- (setq qd (getpoint "\n\n\n没有选在标注曲线上，重新选择："))
- )
- (setq leng (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en) )) ;;;道路总长
- (if (= nil (setq qszh (getreal "\n请输入已知点桩号<0>:"))) (setq qszh 0))
- (if (= nil (setq dist (getreal "\n请输入桩号间距<20>:"))) (setq dist 20))
- (setq qszh (- qszh (* (vlax-curve-getDistAtPoint en qd) fx)))
- (setvar "osmode" 0) ;关闭捕捉
- (command "._erase" (ssget "x" (list (cons 8 "道路桩号"))) "") (setq pzh (fix(/ qszh dist)))
- (setq pzh (- qszh (* pzh dist)))
- (if (= fx 1.0)
- (setq pt1 (vlax-curve-getStartPoint en))
- (setq pt1 (vlax-curve-getEndPoint en))
- )
- (if (= fx 1.0)
- (setq zhz 0)
- (setq zhz (vlax-curve-getDistAtPoint en (vlax-curve-getEndPoint en)))
- )
- (setq zhz (+ zhz (* qszh fx)))
- (setq zhz (* zhz fx))
- (xrbz)
- (setq nn 0)
- (while
- (setq pt1 (vlax-curve-getPointAtDist en (abs(- (* nn (* dist fx)) pzh))))
- (setq zhz (* nn (* dist fx)))
- (setq zhz (+ zhz (- qszh pzh)))
- (xrbz)
- (setq nn (1+ nn))
- )
- (if (= fx 1.0)
- (setq pt1 (vlax-curve-getEndPoint en))
- (setq pt1 (vlax-curve-getStartPoint en))
- )
- (if (= fx 1.0)
- (setq zhz (vlax-curve-getDistAtPoint en (vlax-curve-getEndPoint en)))
- (setq zhz 0)
- )
- (setq zhz (+ zhz (* qszh fx)))
- (setq zhz (* zhz fx))
- (xrbz)
- )
- (defun xrbz(/)
- (Command "layer" "s" "道路桩号" "")
- (if (< zhz 0.0) (setq fh "-") (setq fh "+"))
- (setq nn1 (fix (/ zhz 1000.0)))
- (setq nn2 (abs(- zhz (* 1000.0 nn1))))
- (if (= nn2 0.0) (setq str_1 (strcat fh "00" )))
- (if (and (> nn2 0) (< nn2 10.0)) (setq str_1 (strcat (strcat fh "000" ) (rtos nn2 2 3))))
- (if (and (> nn2 10.0) (< nn2 100.0)) (setq str_1 (strcat (strcat fh "0" ) (rtos nn2 2 0))))
- (if (>= nn2 100.0) (setq str_1 (strcat fh (rtos nn2 2 0))))
- (if (= zhz leng) (setq str_1 (strcat fh (rtos nn2 2 3)))) ;;修改部分2011-06-14
- (if (= qmw 0)
- (if (= (fix (/ nn2 100.0)) (/ nn2 100.0))
- (progn
- (setq str_1 (strcat "K" (rtos nn1 2 0) str_1 ))
- (setq str_1 (strcat qz str_1 ))
- )
- )
- (progn
- (setq str_1 (strcat (rtos nn1 2) str_1 ))
- (setq str_1 (strcat qz str_1 ))
- )
- )
- (setq ang (a-get-Angle en pt1))
- (setq pt2 (polar pt1 (+ ang (/ pi 2)) (* th 2.2)))
- (setq pt3 (polar pt1 (+ ang (* pi 1.5)) (* th 1)))
- (setq st1 (substr str_1 1 1))
- (if (/= st1 fh)
- (progn
- (if (= wf 1.0)
- (setq pt4 (polar pt1 (+ (* pi 1.5) ang) (* th (* 1.65406 zk))))
- (setq pt4 (polar pt1 (+ (* pi 0.5) ang) (* th (* 1.65406 zk))))
- )
- )
- (progn
- (if (= wf 1.0)
- (setq pt4 (polar pt1 (+ (* pi 1.5) ang) (* th (* 1.3582 zk))))
- (setq pt4 (polar pt1 (+ (* pi 0.5) ang) (* th (* 1.3582 zk))))
- )
- )
- )
- (command "line" pt3 pt2 "")
- (if (= wf 1.0)
- ; (setq ang2 (angtos (angle pt1 pt2)0 4) )
- (setq ang2 (angtos (angle pt2 pt1)0 4) )
- )
- (command "text" "bc" pt1 th ang2 str_1 ) ;2014-08-26
- (setq x01 (car pt1))
- (setq y01 (cadr pt1))
- (setq str_1 (strcat (rtos zhz 2 3) ",," (rtos y01 2 3) "," (rtos x01 2 3)",0"))
- (write-line str_1 ff);中桩写入文本(2012-01-10修改)
- (write-line str_1 );显示中桩桩号坐标(2012-01-10修改)
- (princ)
- )
- (setvar "osmode" 703) ;恢复捕捉
- (defun a-get-Angle(ename point / p1 v1 pt-ang)
- (setq v1 (vlax-curve-getfirstderiv ename (vlax-curve-getparamatpoint ename point))
- p1 (mapcar '+ point v1)
- pt-ang (angle point p1))
- pt-ang
- )
- (defun c:sz ()
- (setq xz 1)
- (while (/= xz "")
- (setq xz (getstring "\n\n\n\n [回车退出/文字高度(H)/文字宽度比例(B)/桩号间距(J)/桩号标注方向(F)/文字方向(X)/前缀(Z)/千米位(Q)]:"))
- (cond
- ((= xz "H") "h")
- ((= xz "B") "b")
- ((eq xz "J") "j")
- ((eq xz "F") "f")
- ((eq xz "X") "x")
- ((eq xz "Z") "z")
- ((eq xz "Q") "q")
- (T xz)
- )
- (if (= xz nil) exit)
- (if (= xz "h")
- (progn
- (setq str_2 (strcat "\n\n\n\n 文字高度<" (rtos (getvar "textsize") 2) ">:"))
- (setq th (getreal str_2))
- (if (= th nil) (setq th (getvar "textsize")))
- )
- )
- (if (= xz "b")
- (progn
- (setq zk (getreal "\n\n\n\n\n [文字宽高比例]<0.67>:"))
- (if (= zk nil) (setq zk 0.67))
- (Command "-style" "道路桩号" "仿宋_GB2312" "" zk "" "n" "n")
- )
- )
- (if (= xz "j")
- (if (= nil (setq dist (getreal "\n\n\n\n\n [桩号间距]<20>:"))) (setq dist 20.0))
- )
-
- (if (= xz "f")
- (progn
- (setq fxxz (getstring "\n\n\n\n\n [桩号标注方向[正(Z)/反(F)]<Z>:"))
- (if (= fxxz nil) (setq fxxz "z"))
- (if (= fxxz "z")
- (setq fx 1.0)
- (setq fx -1.0)
- )
-
- (setq wf (* wf fx))
- )
- )
-
- (if (= xz "x")
- (progn
- (if (= nil (setq WZFX (getstring "\n\n\n\n\n 文字方向[前进(Q)/后退(H)]<Q>:"))) (setq WZFX "q"))
- (if (= wzfx "q")
- (setq wf 1.0)
- (setq wf -1.0)
- )
- )
- )
- (if (= xz "z")
- (setq qz (getstring "\n\n\n\n\n 前缀(去除前缀请直接回车):"))
- )
-
- ;;;(initget 1 "1 0")
- (if (= xz "q")
- (if (= nil (setq qmw (getint "[整百桩位标注(0)/全部标注(1)]<0>:"))) (setq qmw 0))
- )
-
- )
- )
任意点桩号标注
- (vl-load-com)
- (vl-load-com)
- (defun c:zhcx ();桩号查询
- (prompt "2010-07-27 zo roo CGGC 武赤公路")
- (prompt "*查询线路任意点桩号* << C:zhcx>> *计算中桩坐标*")
- (setq old_lay (getvar "clayer"))
- (if (=(tblobjname "LAYER" "桩号标注") nil)
- (progn
- (entmake (list
- '(0 . "LAYER")
- '(100 . "AcDbSymbolTableRecord")
- '(100 . "AcDbLayerTableRecord")
- '(6 . "CONTINUOUS")
- '(62 . 3)
- '(70 . 0)
- (cons 2 "桩号标注")
- )
- )
- )
- )
- (setvar "clayer" "桩号标注")
- (setq en (entsel "\n选择道路中心线: ")
- a (getreal "\n请输入起点桩号:")
- e (car en)
- pt (cadr en)
- )
- (if (setq len (getreal "\n输入垂线长度(道路半幅宽):")) ;此处要加入非法输入的控制
- (progn
- (setq OBJ (vlax-ename->vla-object (car en)))
- )
- )
- (while (setq pt0 (getPoint "\n选择查询点："))
- ;画曲线的垂线
- (setq Perpt (vlax-curve-getClosestPointTo OBJ pt0 T)
- LST (vlax-curve-getfirstderiv OBJ (vlax-curve-getparamatpoint OBJ Perpt))
- ANG (atan (/ (cadr LST) (car LST)))
- pt1 (polar Perpt (+ ANG (* 0.5 pi)) len)
- pt2 (polar Perpt (- ANG (* 0.5 pi)) len)
- ;此处就是你画出来的是水平线的原因，变量换个方向即可
- )
- (setq ang2 (angtos (angle pt2 pt1)0 4) )
- (command "pline" pt1 pt2 "")
- ;计算桩号
- (setq leng (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))
- leng1 (+ a (vlax-curve-getDistAtPoint e Perpt))
- leng2 (- leng leng1)
- )
- ;计算桩号
- (if (< leng1 0.0) (setq fh "-") (setq fh "+"))
- (setq nn1 (fix (/ leng1 1000.0 )))
- (setq nn2 (abs(- leng1 (* 1000.0 nn1 ))))
- (if (= nn2 0.0) (setq str_1 (strcat fh "00" )))
- (if (and (> nn2 0) (< nn2 10.0)) (setq str_1 (strcat (strcat fh "00" ) (rtos nn2 2 3))))
- (if (and (> nn2 10.0) (< nn2 100.0)) (setq str_1 (strcat (strcat fh "0" ) (rtos nn2 2 3))))
- (if (>= nn2 100.0) (setq str_1 (strcat fh (rtos nn2 2 3))))
-
- (setq str_1 (strcat "K"(rtos nn1 2 0)"+" (rtos nn2 2 3) ))
- (setq pt4 (polar pt1 (+ (* pi 0.45) ang) (* -2 (* 1.65406 0.67))))
- (command "text" "j" "MC" pt4 "0.3" ang2 str_1)
- (setq py (rtos (nth 0 pt0)));提取测量坐标系Y值
- (setq px (rtos (nth 1 pt0)));提取测量坐标洗X值
- (setq pxy (strcat str_1"中桩坐标：X="px",Y="py))
- (princ pxy)
- )
- (princ)
- )
| 
[复制链接]
发表于 2012-12-18 10:35:42
置顶卡
变色卡
显身卡
楼主
