CAD 多段线文字标注插件

wangsr

谢谢分享。

359321852

飞雪神光 发表于 2024-1-29 11:06
水平有限 就改成这样了

谢谢你的帮助，
在你的基础上也做了一些修改，增加了获取文字高度，和设置

2. (defun c:tt (/ ss ent lis)
   
3. ;多段线每段线中心标注本段线长
   
4.     (setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))
   
5.     (setq h1 (getvar "TEXTSIZE"));获取文本高度
   
6.     (setq h (getreal (strcat "\n请键入文字高度<" (rtos h1 2 2) ">:")))
   
7.   (if (null h)
   
8.     (setq h h1)
   
9.   )
   
10.   (setvar"textsize" h);设置文本高度
    
11.     (setq ent (ssname ss 0))
    
12.     (mapcar
    
13.         '(lambda (x)
    
14.            (setq pt (cadr x))
    
15.            (setq an (last x))(print an)
    
16.            (setq an (if (>= (* pi 1.5) an (* pi 0.5)) (- an pi) an))
    
17.            (setq pt (polar pt (+ an (* pi 0.5)) h));偏离一个文字的高度距离
    
18.            (entmake
    
19.                (list '(0 . "TEXT") '(72 . 1) '(73 . 2)
    
20.                    (cons 1 (car x))
    
21.                    (cons 10 pt)
    
22.                    (cons 11 pt)
    
23.                    (cons 40 h)
    
24.                    (cons 50 an)
    
25.                )
    
26.            )
    
27.        )
    
28.         (mapcar
    
29.             '(lambda (x)
    
30.                (list
    
31.                    (rtos (distance (car x) (cadr x)) 2 2)
    
32.                    (mapcar '* '(0.5 0.5) (mapcar '+ (car x) (cadr x)))
    
33.                    (- (rem (+ (angle (car x) (cadr x)) (* 0.25 pi)) pi) (* 0.25 pi))
    
34.                )
    
35.            )
    
36.             (if (vlax-curve-isClosed ent)
    
37.                 (mapcar 'list
    
38.                     (setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
    
39.                     (append (cdr lis) (list (car lis)))
    
40.                 )
    
41.                 (reverse
    
42.                     (cdr
    
43.                         (reverse
    
44.                             (mapcar 'list
    
45.                                 (setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))
    
46.                                 (append (cdr lis) (list (car lis)))
    
47.                             )
    
48.                         )
    
49.                     )
    
50.                 )
    
51.             )
    
52.         )
    
53.     )
    
54.     (princ)
    
55. )

(defun c:tt (/ ss ent lis)<br /> ;多段线每段线中心标注本段线长<br />     (setq ss (ssget ":P:E" '((0 . "LWPOLYLINE"))))<br />     (setq h1 (getvar "TEXTSIZE"));获取文本高度<br />     (setq h (getreal (strcat "\n请键入文字高度<" (rtos h1 2 2) ">:")))<br />   (if (null h)<br />     (setq h h1)<br />   )<br />   (setvar"textsize" h);设置文本高度<br />     (setq ent (ssname ss 0))<br />     (mapcar<br />         '(lambda (x)<br />            (setq pt (cadr x))<br />            (setq an (last x))(print an)<br />            (setq an (if (>= (* pi 1.5) an (* pi 0.5)) (- an pi) an))<br />            (setq pt (polar pt (+ an (* pi 0.5)) h));偏离一个文字的高度距离<br />            (entmake<br />                (list '(0 . "TEXT") '(72 . 1) '(73 . 2)<br />                    (cons 1 (car x))<br />                    (cons 10 pt)<br />                    (cons 11 pt)<br />                    (cons 40 h)<br />                    (cons 50 an)<br />                )<br />            )<br />        )<br />         (mapcar<br />             '(lambda (x)<br />                (list<br />                    (rtos (distance (car x) (cadr x)) 2 2)<br />                    (mapcar '* '(0.5 0.5) (mapcar '+ (car x) (cadr x)))<br />                    (- (rem (+ (angle (car x) (cadr x)) (* 0.25 pi)) pi) (* 0.25 pi))<br />                )<br />            )<br />             (if (vlax-curve-isClosed ent)<br />                 (mapcar 'list <br />                     (setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))<br />                     (append (cdr lis) (list (car lis)))<br />                 )<br />                 (reverse<br />                     (cdr<br />                         (reverse<br />                             (mapcar 'list <br />                                 (setq lis (mapcar 'cdr (vl-remove-if-not '(lambda (x)(= 10 (car x)))(entget ent))))<br />                                 (append (cdr lis) (list (car lis)))<br />                             )<br />                         )<br />                     )<br />                 )<br />             )<br />         )<br />     )<br />     (princ)<br /> )

yefei812678

好牛逼的插件

azaz042

vitalgg 发表于 2024-1-30 12:25
源码：
https://gitee.com/atlisp/packages/blob/main/at-curve/at-curve.lsp

請問各位大神安裝後指令是什麼 ?
謝謝

azaz042

359321852 发表于 2024-1-31 08:38
谢谢你的帮助，
在你的基础上也做了一些修改，增加了获取文字高度，和设置

弧長好是不正確

vitalgg

azaz042 发表于 2024-2-2 10:13
請問各位大神安裝後指令是什麼 ?
謝謝

没有给具体的指令。
安装核心管理后，可以直接运行函数 (at-curve:per-length) 或者从菜单或命令面板点击。
也可以自己设置指令
(defun c:你想要的指令 ()(at-curve:per-length))

azaz042

vitalgg 发表于 2024-2-2 10:46
没有给具体的指令。
安装核心管理后，可以直接运行函数 (at-curve:per-length) 或者从菜单或命令面板点 ...

atone

厉害厉害，学习中