[原创]文本加下划线程序

langjs · 发表于 2011-1-6 23:42:38

本帖最后由 langjs 于 2011-1-7 11:00 编辑

自己编写了一个文本加双下划线程序，程序比较简单，有需要的拿去用，有什么建议请反馈。QQ59509100
  1月7日根据网友建议更新。

;;; =================================================================
;;; 文本加下划线
;;; 作者：langjs 　　　　命令：TT 　　　　　  日期2011年1月6日
;;; =================================================================
(defun c:TT (/ box ent ent1 h nent1 nent2 np1 np2 np3 np4 old_lay p p1x p1y p2x p2y px py r snap test)
  (setq ent1 (car (entsel "\n选择文本：")))
  (setvar "cmdecho" 0)       ; 关闭命令响应
  (command ".UNDO" "BE")       ; 设置undo起点
  (setq snap (getvar "osmode"))
  (setvar "osmode" 0)       ; 关闭捕捉
  (setq old_lay (getvar "clayer"))    ; 保存当前图层
  (setq ent (entget ent1))
  (if (= "MTEXT" (cdr (assoc 0 ent)))  ; 如选多行文本，则转化为单行文本
(progn
   (command ".EXPLODE" ent1)
   (setq ent1 (entlast))
   (setq ent (entget ent1))
)
(princ)
  )
  (setq p (cdr (assoc 10 ent))       ; 文本基点坐标
h (cdr (assoc 40 ent))       ; 文本高度
r (cdr (assoc 50 ent))       ; 文本旋转角度
TEST (cdr (assoc 8 ent))    ; 文本所在图层
  )
  (setq box (textbox ent))       ; 文本框坐标
  (setq p1x (car (car box))       ; 文本左下角X坐标
p1y (car (cdr (car box)))
p2x (car (car (cdr box)))    ; 文本右上角X坐标
p2y (car (cdr (car (cdr box))))
px (car p)
py (car (cdr p))
  )          ; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
  (setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h
         ; 0.3)竖直方向距0.3倍字高。
  (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
  (setq np3 (list (- px (* h 0.2)) (- py (* h 0.56)))) ; 第二条线段左端点坐标
  (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0)) ; 第二条线段右端点坐标
  (SETVAR "CLAYER" TEST)       ; 文本所在图层设为当前图层
  (COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h
         ; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。
  (setq nent1 (entlast))
  (COMMAND "line" np3 np4 "")       ; 第二条下划线
  (setq nent2 (entlast))
  (if (/= r 0.0)       ; 如果文本不水平则旋转下划线角度
(progn
   (COMMAND "rotate" nent1 "" p (* 180.0 (/ r pi)))
   (COMMAND "rotate" nent2 "" p (* 180.0 (/ r pi)))
)
  )
  (setvar "osmode" snap)
  (setvar "clayer" old_lay)       ; 恢复当前图层
  (command ".UNDO" "E")
  (princ)
)

reeves7 · 发表于 2022-5-3 23:02:25

如果要实现框选多段文字，分别绘制下划线，程序如下，十分简洁：

;; Double Underline - Multiple
(defun c:munder2 ( )
(LM:strikethrough:selection
'(
(-0.8 0.05)
(-1.0 0.05)
)
)
)

zhangrunze · 发表于 2024-4-6 14:38:41

reeves7 发表于 2022-5-3 23:02
如果要实现框选多段文字，分别绘制下划线，程序如下，十分简洁：

感谢分享~
需要线一粗一细可这样写：
(-0.8 0.08)
(-1.0 0.03)

ferious · 发表于 2023-11-14 22:48:23

langjs 发表于 2011-1-7 15:09
回复 hdlyt11 的帖子

;;; =================================================================

郎大师，能否多行文字每行下面画一条？

cnks · 发表于 2011-1-6 23:46:02

支持楼主支持源码

sy100 · 发表于 2011-1-7 00:52:12

谢谢！试过了，很好用。

sy100 · 发表于 2011-1-7 00:59:30

请教楼主：文字和粗线之间的距离和线段两头的长短是由哪些参数控制。简单地说：我想调节文字与下方线段之间的距离和线段的长度。谢谢！

xiaxiang · 发表于 2011-1-7 08:51:23

支持楼主展示源码,学习了

461045462 · 发表于 2011-1-7 09:10:59

谢谢楼主提供的源码
收藏，下来学习学习

langjs · 发表于 2011-1-7 09:25:05

回复 sy100 的帖子

; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数值大小即可。
(setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ;第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h 0.3)竖直方向距0.3倍字高。
(setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ;第一条线段右端点坐标。计算方法同上。
(setq np3 (list (- px (* h 0.2)) (- py (* h 0.56)))) ;第二条线段左端点坐标。计算方法同上。
(setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0));第二条线段右端点坐标。计算方法同上。
;另外还有一句程序
(COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。

hdlyt11 · 发表于 2011-1-7 09:54:29

图层还需处理一下，生成的下划线是图中的当前图层和线性，可否使其为单独图层或者随文字所在图层，且为实线？

langjs · 发表于 2011-1-7 11:02:24

hdlyt11 发表于 2011-1-7 09:54
图层还需处理一下，生成的下划线是图中的当前图层和线性，可否使其为单独图层或者随文字所在图层，且为实线 ...

已经更新，下划线画到文本层了

hdlyt11 · 发表于 2011-1-7 14:46:16

还能把下划线颜色改为6号洋红吗？

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

[基础] [原创]文本加下划线程序

评分

点评