如何让插入文字的高度自动适配屏幕

wzs07

请问如何让插入的数值随时清晰可见，无论比例，无论图幅，就比如cad的菜单内的文字显示高度始终固定，不会造成看不见的现象

2. (princ "\n 程序：（XKBUILD）统计线段长度命令：ll")
   
3. (defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale)
   
4.   (vl-load-com)
   
5.   (setq SUMLEN 0)
   
6.   (setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC"))))
   
7.   (setq N 0)
   
8.   (repeat (sslength SS)
   
9.     (setq CURVE (vlax-ename->vla-object (ssname SS N)))
   
10.     (setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))
    
11.     (setq SUMLEN (+ SUMLEN TLEN))
    
12.     (setq N (1+ N))
    
13.   )
    
14. 
    
15.   (princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米
    
16.   (setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米
    
17.   (setq b (rtos SUMLEN 2 2))  ; 将总长转换成字符串，设置为两个精度，即小数点后两位
    
18.   (setq a (getpoint "\n屏幕单击插入点"))  ; 指定插入点
    
19. 
    
20.   ;; 获取当前视口
    
21.   (setq viewport (vla-get-ActiveViewport (vla-get-ActiveDocument (vlax-get-acad-object))))
    
22.   ;; 获取视口中心和尺寸
    
23.   (setq viewcenter (vlax-get viewport 'Center))
    
24.   (setq viewsizescale (vlax-get viewport 'Height))
    
25. 
    
26.   ;; 计算文字高度，设置为视口高度的1/100
    
27.   (setq txtheight (/ viewsizescale 100))
    
28. 
    
29.   ;; 创建文字图元
    
30.   (entmake
    
31.     (list
    
32.       '(0 . "TEXT")
    
33.       (cons 10 a)  ; 插入点
    
34.       (cons 40 txtheight)  ; 文字高度
    
35.       (cons 1 b)  ; 文字内容
    
36.       '(7 . "Standard")
    
37.       '(72 . 1)
    
38.       (cons 11 (list (car a) (+ (cadr a) txtheight)))  ; 对齐插入点
    
39.     )
    
40.   )
    
41. 
    
42.   (princ)
    
43. )

(princ "\n 程序：（XKBUILD）统计线段长度命令：ll")<br /> (defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale)<br />   (vl-load-com)<br />   (setq SUMLEN 0)<br />   (setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC"))))<br />   (setq N 0)<br />   (repeat (sslength SS)<br />     (setq CURVE (vlax-ename->vla-object (ssname SS N)))<br />     (setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))<br />     (setq SUMLEN (+ SUMLEN TLEN))<br />     (setq N (1+ N))<br />   )<br /> <br />   (princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米<br />   (setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米<br />   (setq b (rtos SUMLEN 2 2))  ; 将总长转换成字符串，设置为两个精度，即小数点后两位<br />   (setq a (getpoint "\n屏幕单击插入点"))  ; 指定插入点<br /> <br />   ;; 获取当前视口<br />   (setq viewport (vla-get-ActiveViewport (vla-get-ActiveDocument (vlax-get-acad-object))))<br />   ;; 获取视口中心和尺寸<br />   (setq viewcenter (vlax-get viewport 'Center))<br />   (setq viewsizescale (vlax-get viewport 'Height))<br /> <br />   ;; 计算文字高度，设置为视口高度的1/100<br />   (setq txtheight (/ viewsizescale 100))<br /> <br />   ;; 创建文字图元<br />   (entmake<br />     (list<br />       '(0 . "TEXT")<br />       (cons 10 a)  ; 插入点<br />       (cons 40 txtheight)  ; 文字高度<br />       (cons 1 b)  ; 文字内容<br />       '(7 . "Standard")<br />       '(72 . 1)<br />       (cons 11 (list (car a) (+ (cadr a) txtheight)))  ; 对齐插入点<br />     )<br />   )<br /> <br />   (princ)<br /> )

ssyfeng

试试是不是这样：

wzs07

ssyfeng 发表于 2024-7-12 16:15
试试是不是这样：

运行错误，参数太多——cad2021

ssyfeng

已更新，可能是复制网页代码时出问题

MZ_li

1. (* (getvar "viewsize") 0.05)

复制代码

核心代码

wzs07

ssyfeng 发表于 2024-7-12 17:12
已更新，可能是复制网页代码时出问题

通过GPT优化对各种线条的支持，请指点

2. (princ "\n 程序：（XKBUILD）统计线段长度命令：ll")
   
3. (defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale objname startpt endpt midpt angle center radius)
   
4.   (vl-load-com)
   
5.   (setq SUMLEN 0)
   
6.   (setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,LWPOLYLINE,SPLINE,ARC"))))
   
7.   (setq N 0)
   
8.   (repeat (sslength SS)
   
9.     (setq CURVE (vlax-ename->vla-object (ssname SS N)))
   
10.     (setq objname (vla-get-ObjectName CURVE))
    
11.     (setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))
    
12.     (setq SUMLEN (+ SUMLEN TLEN))
    
13. 
    
14.     ;; 判断对象类型并处理
    
15.     (cond
    
16.       ;; 如果是直线
    
17.       ((= objname "AcDbLine")
    
18.        ;; 使用 entget 获取起点和终点坐标
    
19.        (setq startpt (cdr (assoc 10 (entget (vlax-vla-object->ename CURVE)))))
    
20.        (setq endpt (cdr (assoc 11 (entget (vlax-vla-object->ename CURVE)))))
    
21.        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
    
22.        ;; 计算文字高度
    
23.        (setq txtheight (* (getvar "viewsize") 0.015))
    
24.        ;; 计算旋转角度
    
25.        (setq angle (atan (/ (- (cadr endpt) (cadr startpt)) (- (car endpt) (car startpt)))))
    
26.        ;; 创建文字图元
    
27.        (entmake
    
28.          (list
    
29.            '(0 . "TEXT")
    
30.            (cons 10 midpt)  ; 插入点
    
31.            (cons 40 txtheight)  ; 文字高度
    
32.            (cons 1 (rtos TLEN 2 0))  ; 文字内容
    
33.            '(7 . "Standard")
    
34.            '(72 . 1)
    
35.            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点
    
36.            (cons 50 angle)  ; 文字旋转角度
    
37.          )
    
38.        )
    
39.       )
    
40.       ;; 如果是圆
    
41.       ((= objname "AcDbCircle")
    
42.        (setq center (vlax-get CURVE 'Center))
    
43.        (setq radius (vlax-get CURVE 'Radius))
    
44.        (setq txtheight (* (getvar "viewsize") 0.015))
    
45.        ;; 创建文字图元
    
46.        (entmake
    
47.          (list
    
48.            '(0 . "TEXT")
    
49.            (cons 10 center)  ; 插入点
    
50.            (cons 40 txtheight)  ; 文字高度
    
51.            (cons 1 (rtos (* 2 pi radius) 2 0))  ; 文字内容，圆周长
    
52.            '(7 . "Standard")
    
53.            '(72 . 1)
    
54.            (cons 11 (list (car center) (+ (cadr center) txtheight)))  ; 对齐插入点
    
55.          )
    
56.        )
    
57.       )
    
58.       ;; 如果是椭圆
    
59.       ((= objname "AcDbEllipse")
    
60.        (setq startpt (vlax-curve-getStartPoint CURVE))
    
61.        (setq endpt (vlax-curve-getEndPoint CURVE))
    
62.        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
    
63.        (setq txtheight (* (getvar "viewsize") 0.015))
    
64.        ;; 创建文字图元
    
65.        (entmake
    
66.          (list
    
67.            '(0 . "TEXT")
    
68.            (cons 10 midpt)  ; 插入点
    
69.            (cons 40 txtheight)  ; 文字高度
    
70.            (cons 1 (rtos TLEN 2 0))  ; 文字内容
    
71.            '(7 . "Standard")
    
72.            '(72 . 1)
    
73.            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点
    
74.          )
    
75.        )
    
76.       )
    
77.       ;; 如果是样条曲线
    
78.       ((= objname "AcDbSpline")
    
79.        (setq startpt (vlax-curve-getStartPoint CURVE))
    
80.        (setq endpt (vlax-curve-getEndPoint CURVE))
    
81.        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
    
82.        (setq txtheight (* (getvar "viewsize") 0.015))
    
83.        ;; 创建文字图元
    
84.        (entmake
    
85.          (list
    
86.            '(0 . "TEXT")
    
87.            (cons 10 midpt)  ; 插入点
    
88.            (cons 40 txtheight)  ; 文字高度
    
89.            (cons 1 (rtos TLEN 2 0))  ; 文字内容
    
90.            '(7 . "Standard")
    
91.            '(72 . 1)
    
92.            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点
    
93.          )
    
94.        )
    
95.       )
    
96.       ;; 如果是圆弧
    
97.       ((= objname "AcDbArc")
    
98.        (setq startpt (vlax-curve-getStartPoint CURVE))
    
99.        (setq endpt (vlax-curve-getEndPoint CURVE))
    
100.        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
     
101.        (setq txtheight (* (getvar "viewsize") 0.015))
     
102.        ;; 创建文字图元
     
103.        (entmake
     
104.          (list
     
105.            '(0 . "TEXT")
     
106.            (cons 10 midpt)  ; 插入点
     
107.            (cons 40 txtheight)  ; 文字高度
     
108.            (cons 1 (rtos TLEN 2 0))  ; 文字内容
     
109.            '(7 . "Standard")
     
110.            '(72 . 1)
     
111.            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点
     
112.          )
     
113.        )
     
114.       )
     
115.       ;; 如果是多段线
     
116.       ((= objname "AcDbPolyline")
     
117.        ;; 不做特殊处理，继续累加总长度
     
118.       )
     
119.     )
     
120. 
     
121.     (setq N (1+ N))
     
122.   )
     
123.   
     
124.   ;; 判断是否需要插入总长度文字
     
125.   (if (or (> (sslength SS) 1) (= objname "AcDbPolyline"))
     
126.     (progn
     
127.       (princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米
     
128.       (setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米
     
129.       (setq b (rtos SUMLEN 2 2))  ; 将总长转换成字符串，设置为两个精度，即小数点后两位
     
130.       (setq a (getpoint "\n屏幕单击插入点"))  ; 指定插入点
     
131. 
     
132.       ;; 计算文字高度
     
133.       (setq txtheight (* (getvar "viewsize") 0.015))
     
134. 
     
135.       ;; 创建文字图元
     
136.       (entmake
     
137.         (list
     
138.           '(0 . "TEXT")
     
139.           (cons 10 a)  ; 插入点
     
140.           (cons 40 txtheight)  ; 文字高度
     
141.           (cons 1 (strcat "总长 " b " m"))  ; 文字内容，现在是在总长度前加上了“总长”，后加了“ m”
     
142.           '(7 . "Standard")
     
143.           '(72 . 1)
     
144.           (cons 11 (list (car a) (+ (cadr a) txtheight)))  ; 对齐插入点
     
145.         )
     
146.       )
     
147.     )
     
148.   )
     
149.   (princ)
     
150. )
     

(princ "\n 程序：（XKBUILD）统计线段长度命令：ll")<br /> (defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale objname startpt endpt midpt angle center radius)<br />   (vl-load-com)<br />   (setq SUMLEN 0)<br />   (setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,LWPOLYLINE,SPLINE,ARC"))))<br />   (setq N 0)<br />   (repeat (sslength SS)<br />     (setq CURVE (vlax-ename->vla-object (ssname SS N)))<br />     (setq objname (vla-get-ObjectName CURVE))<br />     (setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))<br />     (setq SUMLEN (+ SUMLEN TLEN))<br /> <br />     ;; 判断对象类型并处理<br />     (cond<br />       ;; 如果是直线<br />       ((= objname "AcDbLine")<br />        ;; 使用 entget 获取起点和终点坐标<br />        (setq startpt (cdr (assoc 10 (entget (vlax-vla-object->ename CURVE)))))<br />        (setq endpt (cdr (assoc 11 (entget (vlax-vla-object->ename CURVE)))))<br />        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))<br />        ;; 计算文字高度<br />        (setq txtheight (* (getvar "viewsize") 0.015))<br />        ;; 计算旋转角度<br />        (setq angle (atan (/ (- (cadr endpt) (cadr startpt)) (- (car endpt) (car startpt)))))<br />        ;; 创建文字图元<br />        (entmake<br />          (list<br />            '(0 . "TEXT")<br />            (cons 10 midpt)  ; 插入点<br />            (cons 40 txtheight)  ; 文字高度<br />            (cons 1 (rtos TLEN 2 0))  ; 文字内容<br />            '(7 . "Standard")<br />            '(72 . 1)<br />            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点<br />            (cons 50 angle)  ; 文字旋转角度<br />          )<br />        )<br />       )<br />       ;; 如果是圆<br />       ((= objname "AcDbCircle")<br />        (setq center (vlax-get CURVE 'Center))<br />        (setq radius (vlax-get CURVE 'Radius))<br />        (setq txtheight (* (getvar "viewsize") 0.015))<br />        ;; 创建文字图元<br />        (entmake<br />          (list<br />            '(0 . "TEXT")<br />            (cons 10 center)  ; 插入点<br />            (cons 40 txtheight)  ; 文字高度<br />            (cons 1 (rtos (* 2 pi radius) 2 0))  ; 文字内容，圆周长<br />            '(7 . "Standard")<br />            '(72 . 1)<br />            (cons 11 (list (car center) (+ (cadr center) txtheight)))  ; 对齐插入点<br />          )<br />        )<br />       )<br />       ;; 如果是椭圆<br />       ((= objname "AcDbEllipse")<br />        (setq startpt (vlax-curve-getStartPoint CURVE))<br />        (setq endpt (vlax-curve-getEndPoint CURVE))<br />        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))<br />        (setq txtheight (* (getvar "viewsize") 0.015))<br />        ;; 创建文字图元<br />        (entmake<br />          (list<br />            '(0 . "TEXT")<br />            (cons 10 midpt)  ; 插入点<br />            (cons 40 txtheight)  ; 文字高度<br />            (cons 1 (rtos TLEN 2 0))  ; 文字内容<br />            '(7 . "Standard")<br />            '(72 . 1)<br />            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点<br />          )<br />        )<br />       )<br />       ;; 如果是样条曲线<br />       ((= objname "AcDbSpline")<br />        (setq startpt (vlax-curve-getStartPoint CURVE))<br />        (setq endpt (vlax-curve-getEndPoint CURVE))<br />        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))<br />        (setq txtheight (* (getvar "viewsize") 0.015))<br />        ;; 创建文字图元<br />        (entmake<br />          (list<br />            '(0 . "TEXT")<br />            (cons 10 midpt)  ; 插入点<br />            (cons 40 txtheight)  ; 文字高度<br />            (cons 1 (rtos TLEN 2 0))  ; 文字内容<br />            '(7 . "Standard")<br />            '(72 . 1)<br />            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点<br />          )<br />        )<br />       )<br />       ;; 如果是圆弧<br />       ((= objname "AcDbArc")<br />        (setq startpt (vlax-curve-getStartPoint CURVE))<br />        (setq endpt (vlax-curve-getEndPoint CURVE))<br />        (setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))<br />        (setq txtheight (* (getvar "viewsize") 0.015))<br />        ;; 创建文字图元<br />        (entmake<br />          (list<br />            '(0 . "TEXT")<br />            (cons 10 midpt)  ; 插入点<br />            (cons 40 txtheight)  ; 文字高度<br />            (cons 1 (rtos TLEN 2 0))  ; 文字内容<br />            '(7 . "Standard")<br />            '(72 . 1)<br />            (cons 11 (list (car midpt) (+ (cadr midpt) txtheight)))  ; 对齐插入点<br />          )<br />        )<br />       )<br />       ;; 如果是多段线<br />       ((= objname "AcDbPolyline")<br />        ;; 不做特殊处理，继续累加总长度<br />       )<br />     )<br /> <br />     (setq N (1+ N))<br />   )<br />   <br />   ;; 判断是否需要插入总长度文字<br />   (if (or (> (sslength SS) 1) (= objname "AcDbPolyline"))<br />     (progn<br />       (princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米<br />       (setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米<br />       (setq b (rtos SUMLEN 2 2))  ; 将总长转换成字符串，设置为两个精度，即小数点后两位<br />       (setq a (getpoint "\n屏幕单击插入点"))  ; 指定插入点<br /> <br />       ;; 计算文字高度<br />       (setq txtheight (* (getvar "viewsize") 0.015))<br /> <br />       ;; 创建文字图元<br />       (entmake<br />         (list<br />           '(0 . "TEXT")<br />           (cons 10 a)  ; 插入点<br />           (cons 40 txtheight)  ; 文字高度<br />           (cons 1 (strcat "总长 " b " m"))  ; 文字内容，现在是在总长度前加上了“总长”，后加了“ m”<br />           '(7 . "Standard")<br />           '(72 . 1)<br />           (cons 11 (list (car a) (+ (cadr a) txtheight)))  ; 对齐插入点<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

XPG

看看，学习一下

ssyfeng

wzs07 发表于 2024-7-12 21:34
通过GPT优化对各种线条的支持，请指点

不想看GPT的代码

gble119

多谢分享  学习了

jkop

测试如右，插件可以显示线的长度，并不会显示多义线长度，但均会显示总长度，对我来说有帮助，谢谢分享！