沿曲线标注高程
;; 测量选定曲线上两点之间的距离(defun apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)
;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派工具箱,摄影24942984
;(setq ENOBJ (CAR (ENTSEL)))
;(setq p1 (getpoint "\n选择曲线上的一点："))
;(setq p2 (getpoint "\n选择曲线上的另一点："))
(setq dist1 (vlax-curve-getDistAtPoint enobj p1))
(setq dist2 (vlax-curve-getDistAtPoint enobj p2))
;(print "\n测量段曲线长度：")
(setq dist (abs (- dist1 dist2)))
dist
)
(defun c:bg (/ ENOBJ p1 p2 s1 s2 p3dist gcc bz dist1 xgc)
(setq ENOBJ (CAR (ENTSEL "\n请选择线段")))
(setq p1 (getpoint "\n选择曲线上的一点："))
(setq s1 (getreal "\n请输入该点标高："))
(setq p2 (getpoint "\n选择曲线上的另一点："))
(setq s2 (getreal "\n请输入该点标高："))
(setq dist (apkl ENOBJ p1 p2 ))
(setq gcc (- s1 s2))
(setq bz (/ gcc dist))
(while (setq p3 (getpoint "\n选择曲线上要查询的一点："))
(setq dist1 (apkl ENOBJ p3 p2 ) )
(setq xgc (+ s2 (* dist1 bz )))
(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
)
(princ)
)
测绘板块就你还活跃着 ; 错误: 输入的字符串有缺陷 文字如能垂直于曲线可能更加美观。 好东西顶一个 本帖最后由 树櫴希德 于 2022-10-22 23:36 编辑
(defun mkgcd (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" "GC2000"))
(progn
;13、entmake生成普通块
(defun emkblk ( pt name /)
(entmake (list '(0 . "block") (cons 2 name) '(70 . 0) (cons 10 pt)))
(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) ))
(cons 10 (list (+ (car pt) 4.25)(+ (cadr pt) 1) ))
))
(entmake '((0 . "ENDBLK")))
;(entmake (list '(0 . "INSERT") (cons 2 name) (cons 10 pt)))
)
(emkblk '(0 0) "GC2000")
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC2000")
(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) (* 2.25 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 apkl (ENOBJ p1 p2 / DIST DIST1 DIST2 EN ENOBJ OSM P1 P2)
;;;来源：QQ群友：GreenWood(181976640)。属QQ群：SP编程,e派<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>箱,摄影24942984
;(setq ENOBJ (CAR (ENTSEL)))
;(setq p1 (getpoint "\n选择曲线上的一点："))
;(setq p2 (getpoint "\n选择曲线上的另一点："))
(setq dist1 (vlax-curve-getDistAtPoint enobj p1))
(setq dist2 (vlax-curve-getDistAtPoint enobj p2))
;(print "\n测量段曲线长度：")
(setq dist (abs (- dist1 dist2)))
dist
)
(defun c:bg (/ ENOBJ p1 p2 s1 s2 p3dist gcc bz dist1 xgc p33)
(setq ENOBJ (CAR (ENTSEL "\n请选择线段")))
(setq p1 (getpoint "\n选择曲线上的一点："))
(setq s1 (getreal "\n请输入该点标高："))
(setq p2 (getpoint "\n选择曲线上的另一点："))
(setq s2 (getreal "\n请输入该点标高："))
(setq dist (apkl ENOBJ p1 p2 ))
(setq gcc (- s1 s2))
(setq bz (/ gcc dist))
(while (setq p33 (getpoint "\n选择曲线上要查询的一点：")
p3 (vlax-curve-getClosestPointTo ENOBJ p33 T)
)
(setq dist1 (apkl ENOBJ p3 p2 ) )
(setq xgc (+ s2 (* dist1 bz )))
(mkgcd p3 xgc1)
(command "rotate" (entlast) "" p3 (* (- (angle p3 p33) (/ pi 2) ) (/ 180 pi) ))
;(entmake (list '(0 . "TEXT") '(8 . "fgbj")(cons 1 (rtos xgc 2 3)) (cons 10 p3 ) (cons 40 1.0)))
)
(princ)
) 树櫴希德 发表于 2022-10-14 23:31
大佬重出江湖啦～ 这个对渐变高程分有用！:lol 148.954,80.6901(vlax-curve-getClosestPointTo (vlax-ename->vla-object (car (entsel)))(getpoint) )
页:
[1]