链测长度lisp到等高线标签
请帮我编辑此代码。它沿多段线创建链测长度。我想要的是将“CH 0.00”更改为多段线的高程值
(defun c:cr (/)
(vl-load-com)
(defun _Line (p b o)
(entmake
(append
'((0 . "line")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "C-CTRL_TICK")
(100 . "AcDbLine")
)
(list (cons 10 (polar p b o)))
(list (cons 11 (polar p (+ b PI) o)))
'((210 0.0 0.0 1.0))
)
)
)
(defun _text (p b o h c)
(entmake
(append
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "C-CTRL_TXT")
(100 . "AcDbMText")
)
(list (cons 10 (polar p (+ b PI) o))
)
(list (cons 40 h))
(list (cons 1 (strcat "CH "
(if (setq ld (nth (strlen (rtosc 3 0)) '(x "")))
ld "")
(rtos c 2 2))))
(list (cons 50 (+ b PI)))
(list '(41 . 0)
'(90 . 3)
'(63 . 256)
'(441 . 3935927)
'(71 . 4)
'(72 . 5)
(cons 7 (getvar "textstyle"))
'(210 0.0 0.0 1.0)
'(73 . 1)
)
)
)
)
(defun _ang (p1 p2)(+ (angle p1 p2) (/ PI 2.0)))
(setq dist (getdist "increment: "))
(setq offset (getdist "tick size: "))
(setq height (getdist "text height: "))
(setq to (getdist "text offset: "))
(setq ss (ssget)
count 0
dist dist
offset offset
height height
)
(repeat (sslength ss)
(setq ent (ssname ss count)
obj (vlax-ename->vla-object ent)
chainage dist
)
(_line (setq p (vlax-curve-getstartpoint obj))
(setq bearing (_ang p (vlax-curve-getPointAtDist obj (+ chainage 0.001))))
offset)
(_text p bearing to height 0.0)
(while
(and
(setq point1 (vlax-curve-getPointAtDist obj chainage))
(setq point2 (vlax-curve-getPointAtDist obj (+ chainage 0.001)))
)
(setq bearing (+ (angle point1 point2) (/ PI 2.0)))
(_line point1 bearing offset)
(_text point1 bearing to height chainage)
(setq chainage (+ chainage dist))
)
(setq count (1+ count))
)
) 要获得高程，请调整这些线：
如果不是您开发的，请指定该工具的自动恢复。 你好，米尔恰。
谢谢你的帮助。
你能帮我再次编辑这个代码吗？
我想要的是，当多段线的长度小于用户输入的增量值时，文本必须位于多段线的中间。
有可能吗？
;;;;;CONTOUR LABELING;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;based on chainage lisp posted by sean.keohane ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:cl (/)
(vl-load-com)
(defun _text (p b o h c)
(entmake
(append
'((0 . "MTEXT")
(100 . "AcDbEntity")
(67 . 0)
(410 . "Model")
(8 . "C-CTRL_TXT")
(100 . "AcDbMText")
)
(list (cons 10 (polar p (+ b PI) o))
)
(list (cons 40 h))
(list (cons 1 (strcat ""(if (setq ld (nth (strlen (rtosc 2 0)) '(x "")))ld "")(rtos c 2 0))));<--:Elevation Value;;;
(list (cons 50 (+ b (/ pi 2))));<--Rotation angle of text;;
(list '(41 . 0)
'(90 . 3);<-- Mask
'(63 . 256);<--Mask
'(441 . 3935927);<-- Mask
'(71 . 5);<--Justification:Middle Center;;
'(72 . 5)
(cons 7 (getvar "textstyle"));<--:Current text style;;
'(210 0.0 0.0 1.0)
'(73 . 3)
)
)
)
)
(defun _ang (p1 p2)(+ (angle p1 p2) (/(* 3 PI) 2.0)))
(setq dist (cond ((getdist "increment <400>:"))(400)));<--:Contour Label Increment;;
(setq offset 0)
(setq height 2.5);<--:default text height;;
(setq to 0)
(setq ss (ssget)
count 0
dist dist
offset offset
height height
)
(repeat (sslength ss)
(setq ent (ssname ss count)
obj (vlax-ename->vla-object ent)
chainage dist)
(_text p bearing to height (caddr p))
(while
(and
(setq point1 (vlax-curve-getPointAtDist obj chainage))
(setq point2 (vlax-curve-getPointAtDist obj (+ chainage 0.001)))
)
(setq bearing (+ (angle point1 point2) (/(* 3 PI )2.0)))
(_text point1 bearing to height (caddr point1))
(setq chainage (+ chainage dist))
)
(setq count (1+ count))
)
) 我认为它是在这里定义的。
(_text p bearing to height (caddr p))
Mircea是正确的。
你的（setq方位…）在while循环内，但（_text p bearing to height（caddr p））在while之前
(setq bearing (+ (angle point1 point2) (/(* 3 PI )2.0)))
对不起，我忽略了
我还意识到我发布的第二个代码不完整。
谢谢hanhphuc
你好，hanhphuc
你能查一下这个代码吗。
对我来说效果很好，但仍然需要你们的帮助。
如果多段线的长度小于等高线间隔，则不会创建标签。
;;; (_text p bearing to height (caddr p)) <--- try to remove this line
(while
(and
...
...
你希望程序做什么？终止程序？还是做点别的？ 我想标记多段线的中点 对于长度小于间隔值的*行，在开始/中间/结束处会是文本吗？
或者开始和结束就足够了？
页:
[1]
2