CAD 多段线文字标注插件
(defun c:tt (/ ss ent lis);多段线每段线中心标注本段线长
(setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))
(setq ent (ssname ss 0))
(mapcar '(lambda (x)
(entmake (list '(0 . "TEXT") '(72 . 1) '(73 . 2)
(cons 1 (car x))
(cons 10 (cadr x))
(cons 11 (cadr x))
(cons 40 2.5)
(cons 50 (last x)))))
(mapcar '(lambda (x)
(list (rtos (distance (car x)
(cadr x)) 2 2) (mapcar '* '(0.5 0.5)
(mapcar '+ (car x)
(cadr x)))
(- (rem (+ (angle (car x)
(cadr x))
(* 0.25 pi)) pi)
(* 0.25 pi))))
(mapcar 'list (setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)
(= 10 (car x)))
(entget ent)))) (append (cdr lis)
(list (car lis))))))
(princ)
)
水平有限 就改成这样了(defun c:tt (/ ss ent lis)
;多段线每段线中心标注本段线长
(setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))
(setq ent (ssname ss 0))
(mapcar
'(lambda (x)
(setq pt (cadr x))
(setq an (last x))(print an)
(setq an (if (>= (* pi 1.5) an (* pi 0.5)) (- an pi) an))
(setq pt (polar pt (+ an (* pi 0.5)) 2.5))
(entmake
(list '(0 . "TEXT") '(72 . 1) '(73 . 2)
(cons 1 (car x))
(cons 10 pt)
(cons 11 pt)
(cons 40 2.5)
(cons 50 an)
)
)
)
(mapcar
'(lambda (x)
(list
(rtos (distance (car x) (cadr x)) 2 2)
(mapcar '* '(0.5 0.5) (mapcar '+ (car x) (cadr x)))
(- (rem (+ (angle (car x) (cadr x)) (* 0.25 pi)) pi) (* 0.25 pi))
)
)
(if (vlax-curve-isClosed ent)
(mapcar 'list
(setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
(append (cdr lis) (list (car lis)))
)
(reverse
(cdr
(reverse
(mapcar 'list
(setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
(append (cdr lis) (list (car lis)))
)
)
)
)
)
)
)
(princ)
) 本帖最后由 359321852 于 2024-1-31 08:41 编辑
飞雪神光 发表于 2024-1-29 11:06
水平有限 就改成这样了
谢谢你的帮助，
在你的基础上也做了一些修改，增加了获取文字高度，和设置
(defun c:tt (/ ss ent lis)
;多段线每段线中心标注本段线长
(setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))
(setq h1 (getvar "TEXTSIZE"));获取文本高度
(setq h (getreal (strcat "\n请键入文字高度<" (rtos h1 2 2) ">:")))
(if (null h)
(setq h h1)
)
(setvar"textsize" h);设置文本高度
(setq ent (ssname ss 0))
(mapcar
'(lambda (x)
(setq pt (cadr x))
(setq an (last x))(print an)
(setq an (if (>= (* pi 1.5) an (* pi 0.5)) (- an pi) an))
(setq pt (polar pt (+ an (* pi 0.5)) h));偏离一个文字的高度距离
(entmake
(list '(0 . "TEXT") '(72 . 1) '(73 . 2)
(cons 1 (car x))
(cons 10 pt)
(cons 11 pt)
(cons 40 h)
(cons 50 an)
)
)
)
(mapcar
'(lambda (x)
(list
(rtos (distance (car x) (cadr x)) 2 2)
(mapcar '* '(0.5 0.5) (mapcar '+ (car x) (cadr x)))
(- (rem (+ (angle (car x) (cadr x)) (* 0.25 pi)) pi) (* 0.25 pi))
)
)
(if (vlax-curve-isClosed ent)
(mapcar 'list
(setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
(append (cdr lis) (list (car lis)))
)
(reverse
(cdr
(reverse
(mapcar 'list
(setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
(append (cdr lis) (list (car lis)))
)
)
)
)
)
)
)
(princ)
) (defun c:tt (/ ss ent lis)
(setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))
(setq ent (ssname ss 0) th 25)
(mapcar
'(lambda (y)
(entmakeX
(list '(0 . "TEXT")
(cons 1 (car y))
(cons 10
(polar (cadr y) (+ (last y) (* 0.5 pi)) (* th 0.5))
)
(cons 40 th)
(cons 50 (last y))
)
)
)
(MAPCAR
(FUNCTION
(LAMBDA (X)
(SETQ P1 (CDR (ASSOC 10 (ENTGET X)))
P2 (CDR (ASSOC 11 (ENTGET X)))
PP (ENTDEL X)
)
(LIST
(vl-princ-to-string (DISTANCE P1 P2))
(MAPCAR (FUNCTION (LAMBDA (E1 E2) (* 0.5 (+ E1 E2))))
P1
P2
)
(- (rem (+ (angle p1 p2)
(* 0.25 pi)
)
pi
)
(* 0.25 pi)
)
)
)
)
(MAPCAR 'vlax-vla-object->ename
(vlax-safearray->list
(vlax-variant-value
(vla-Explode (vlax-ename->vla-object ENT))
)
)
)
)
)
(princ)
)
插件有缺陷，会多出一个收尾端点的长度标注，请高手帮忙修改一下，
最好能让文字向上偏离文字的高度。 这个首尾相接的函数写的真好 又涨知识了 本帖最后由 xyp1964 于 2024-1-30 22:52 编辑
;;需要考虑带弧线段以及闭合的情况
(defun c:tt ()
(xyp-Start)
(setq i -1)
(if (setq ss (ssget '((0 . "LWPOLYLINE"))))
(while (setq s1 (ssname ss (setq i (1+ i))))
(xyp-SubLengDimTxt s1 t 1 2)
)
)
(xyp-End)
)
xyp1964 发表于 2024-1-29 13:44
;;需要考虑带弧线段的情况
您的这个带弧的共享下谢谢 xyp1964 发表于 2024-1-29 13:44
;;需要考虑带弧线段的情况
分享一下谢谢 wangsr 发表于 2024-1-29 13:56
您的这个带弧的共享下谢谢
院长的风格，伪代码，知道吧 http://s1.atlisp.cn/static/videos/标注曲线的每段长度.mp4
源码：
https://gitee.com/atlisp/packages/blob/main/at-curve/at-curve.lsp
页:
[1]
2