CAD 多段线文字标注插件

359321852 · 发表于 2024-1-29 10:13:45

(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)
)

飞雪神光 · 发表于 2024-1-29 11:06:30

水平有限就改成这样了

(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)
)

(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:38:06

本帖最后由 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 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) 
)

liuhe · 发表于 2024-1-29 12:48:33

(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)
)

(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) 
 
)

359321852 · 发表于 2024-1-29 10:23:04

插件有缺陷，会多出一个收尾端点的长度标注，请高手帮忙修改一下，
最好能让文字向上偏离文字的高度。

飞雪神光 · 发表于 2024-1-29 11:21:16

这个首尾相接的函数写的真好又涨知识了

xyp1964 · 发表于 2024-1-29 13:44:02

本帖最后由 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)
)

wangsr · 发表于 2024-1-29 13:56:28

xyp1964 发表于 2024-1-29 13:44
;;需要考虑带弧线段的情况

您的这个带弧的共享下谢谢

664571221 · 发表于 2024-1-29 16:28:43

xyp1964 发表于 2024-1-29 13:44
;;需要考虑带弧线段的情况

分享一下谢谢

tomonkey239 · 发表于 2024-1-30 08:58:57

wangsr 发表于 2024-1-29 13:56
您的这个带弧的共享下谢谢

院长的风格，伪代码，知道吧

vitalgg · 发表于 2024-1-30 12:25:10

如果无法播放，请点击此处在新窗口打开

源码：
https://gitee.com/atlisp/packages/blob/main/at-curve/at-curve.lsp

账号		自动登录	找回密码
密码			注册

[源码] CAD 多段线文字标注插件

本帖子中包含更多资源

点评

本帖子中包含更多资源

本帖子中包含更多资源