如何让插入文字的高度自动适配屏幕
请问如何让插入的数值随时清晰可见，无论比例，无论图幅，就比如cad的菜单内的文字显示高度始终固定，不会造成看不见的现象(princ "\n 程序：（XKBUILD）统计线段长度命令：ll")
(defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale)
(vl-load-com)
(setq SUMLEN 0)
(setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE,ARC"))))
(setq N 0)
(repeat (sslength SS)
(setq CURVE (vlax-ename->vla-object (ssname SS N)))
(setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))
(setq SUMLEN (+ SUMLEN TLEN))
(setq N (1+ N))
)
(princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米
(setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米
(setq b (rtos SUMLEN 2 2)); 将总长转换成字符串，设置为两个精度，即小数点后两位
(setq a (getpoint "\n屏幕单击插入点")); 指定插入点
;; 获取当前视口
(setq viewport (vla-get-ActiveViewport (vla-get-ActiveDocument (vlax-get-acad-object))))
;; 获取视口中心和尺寸
(setq viewcenter (vlax-get viewport 'Center))
(setq viewsizescale (vlax-get viewport 'Height))
;; 计算文字高度，设置为视口高度的1/100
(setq txtheight (/ viewsizescale 100))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 a); 插入点
(cons 40 txtheight); 文字高度
(cons 1 b); 文字内容
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car a) (+ (cadr a) txtheight))); 对齐插入点
)
)
(princ)
)
本帖最后由 ssyfeng 于 2024-7-12 17:11 编辑
试试是不是这样：
本帖最后由 wzs07 于 2024-7-12 17:09 编辑
ssyfeng 发表于 2024-7-12 16:15
试试是不是这样：
运行错误，参数太多——cad2021
https://s21.ax1x.com/2024/07/12/pk4nYkV.jpg 已更新，可能是复制网页代码时出问题 (* (getvar "viewsize") 0.05)
核心代码 ssyfeng 发表于 2024-7-12 17:12
已更新，可能是复制网页代码时出问题
通过GPT优化对各种线条的支持，请指点
(princ "\n 程序：（XKBUILD）统计线段长度命令：ll")
(defun C:ll (/ CURVE TLEN SS N SUMLEN a b txtheight viewport viewcenter viewsizescale objname startpt endpt midpt angle center radius)
(vl-load-com)
(setq SUMLEN 0)
(setq SS (ssget '((0 . "CIRCLE,ELLIPSE,LINE,LWPOLYLINE,SPLINE,ARC"))))
(setq N 0)
(repeat (sslength SS)
(setq CURVE (vlax-ename->vla-object (ssname SS N)))
(setq objname (vla-get-ObjectName CURVE))
(setq TLEN (vlax-curve-getdistatparam CURVE (vlax-curve-getendparam CURVE)))
(setq SUMLEN (+ SUMLEN TLEN))
;; 判断对象类型并处理
(cond
;; 如果是直线
((= objname "AcDbLine")
;; 使用 entget 获取起点和终点坐标
(setq startpt (cdr (assoc 10 (entget (vlax-vla-object->ename CURVE)))))
(setq endpt (cdr (assoc 11 (entget (vlax-vla-object->ename CURVE)))))
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
;; 计算文字高度
(setq txtheight (* (getvar "viewsize") 0.015))
;; 计算旋转角度
(setq angle (atan (/ (- (cadr endpt) (cadr startpt)) (- (car endpt) (car startpt)))))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 midpt); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (rtos TLEN 2 0)); 文字内容
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car midpt) (+ (cadr midpt) txtheight))); 对齐插入点
(cons 50 angle); 文字旋转角度
)
)
)
;; 如果是圆
((= objname "AcDbCircle")
(setq center (vlax-get CURVE 'Center))
(setq radius (vlax-get CURVE 'Radius))
(setq txtheight (* (getvar "viewsize") 0.015))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 center); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (rtos (* 2 pi radius) 2 0)); 文字内容，圆周长
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car center) (+ (cadr center) txtheight))); 对齐插入点
)
)
)
;; 如果是椭圆
((= objname "AcDbEllipse")
(setq startpt (vlax-curve-getStartPoint CURVE))
(setq endpt (vlax-curve-getEndPoint CURVE))
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
(setq txtheight (* (getvar "viewsize") 0.015))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 midpt); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (rtos TLEN 2 0)); 文字内容
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car midpt) (+ (cadr midpt) txtheight))); 对齐插入点
)
)
)
;; 如果是样条曲线
((= objname "AcDbSpline")
(setq startpt (vlax-curve-getStartPoint CURVE))
(setq endpt (vlax-curve-getEndPoint CURVE))
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
(setq txtheight (* (getvar "viewsize") 0.015))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 midpt); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (rtos TLEN 2 0)); 文字内容
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car midpt) (+ (cadr midpt) txtheight))); 对齐插入点
)
)
)
;; 如果是圆弧
((= objname "AcDbArc")
(setq startpt (vlax-curve-getStartPoint CURVE))
(setq endpt (vlax-curve-getEndPoint CURVE))
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) startpt endpt))
(setq txtheight (* (getvar "viewsize") 0.015))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 midpt); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (rtos TLEN 2 0)); 文字内容
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car midpt) (+ (cadr midpt) txtheight))); 对齐插入点
)
)
)
;; 如果是多段线
((= objname "AcDbPolyline")
;; 不做特殊处理，继续累加总长度
)
)
(setq N (1+ N))
)
;; 判断是否需要插入总长度文字
(if (or (> (sslength SS) 1) (= objname "AcDbPolyline"))
(progn
(princ (strcat "\n共选择" (itoa (sslength SS)) "条线段，总长" (rtos SUMLEN 2 0) "mm.")) ; 显示总长度，单位为毫米
(setq SUMLEN (/ SUMLEN 1000.0)) ; 将总长度转换为米
(setq b (rtos SUMLEN 2 2)); 将总长转换成字符串，设置为两个精度，即小数点后两位
(setq a (getpoint "\n屏幕单击插入点")); 指定插入点
;; 计算文字高度
(setq txtheight (* (getvar "viewsize") 0.015))
;; 创建文字图元
(entmake
(list
'(0 . "TEXT")
(cons 10 a); 插入点
(cons 40 txtheight); 文字高度
(cons 1 (strcat "总长 " b " m")); 文字内容，现在是在总长度前加上了“总长”，后加了“ m”
'(7 . "Standard")
'(72 . 1)
(cons 11 (list (car a) (+ (cadr a) txtheight))); 对齐插入点
)
)
)
)
(princ)
)
看看，学习一下 wzs07 发表于 2024-7-12 21:34
通过GPT优化对各种线条的支持，请指点
不想看GPT的代码 多谢分享学习了 测试如右，插件可以显示线的长度，并不会显示多义线长度，但均会显示总长度，对我来说有帮助，谢谢分享！
页:
[1]