明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2072|回复: 8

[资源] 文本加下划线程序的完善

[复制链接]
发表于 2016-6-8 09:22:59 | 显示全部楼层 |阅读模式
这个文本加下划线程序是网上下载的,很好用,但是它只能单个选择文本,高手可以优化一下吗,改为可以多选文本,这样对于有几个文本同时需要加下划线时,可以提高效率
  1. ;;; =================================================================
  2. ;;; 文本加杨红颜色下划线
  3. ;;; 作者:langjs       命令:WTH        日期2011年1月6日
  4. ;;; =================================================================
  5. (defun c:WTH (/ box ent ent1 h nent1 nent2 np1 np2 np3 np4 old_lay p p1x p1y p2x p2y px py r snap test)
  6.   (setq ent1 (car (entsel "\n选择文本:")))
  7.   (setvar "cmdecho" 0)                       ; 关闭命令响应
  8.   (command ".UNDO" "BE")               ; 设置undo起点
  9.   (setq snap (getvar "osmode"))
  10.   (setvar "osmode" 0)                       ; 关闭捕捉
  11.   (setq old_lay (getvar "clayer"))     ; 保存当前图层
  12.   (setq ent (entget ent1))
  13.   (if (= "MTEXT" (cdr (assoc 0 ent)))  ; 如选多行文本,则转化为单行文本
  14.     (progn
  15.       (command ".EXPLODE" ent1)
  16.       (setq ent1 (entlast))
  17.       (setq ent (entget ent1))
  18.     )
  19.     (princ)
  20.   )
  21.   (setq p (cdr (assoc 10 ent))               ; 文本基点坐标
  22.         h (cdr (assoc 40 ent))               ; 文本高度
  23.         r (cdr (assoc 50 ent))               ; 文本旋转角度
  24.         TEST (cdr (assoc 8 ent))       ; 文本所在图层

  25.   )
  26.   (setq box (textbox ent))               ; 文本框坐标
  27.   (setq p1x (car (car box))               ; 文本左下角X坐标
  28.         p1y (car (cdr (car box)))
  29.         p2x (car (car (cdr box)))      ; 文本右上角X坐标
  30.         p2y (car (cdr (car (cdr box))))
  31.         px (car p)
  32.         py (car (cdr p))
  33.   )                                       ; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
  34.   (setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度,(* h
  35.                                        ; 0.3)竖直方向距0.3倍字高。
  36.   (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
  37.   (setq np3 (list (- px (* h 0.2)) (- py (* h 0.46)))) ; 第二条线段左端点坐标
  38.   (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.46)) 0.0)) ; 第二条线段右端点坐标
  39.   (SETVAR "CLAYER" TEST)               ; 文本所在图层设为当前图层
  40.   (COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h
  41.                                        ; 10)指第一条下划线宽度为文本高度的0.1倍,如需调整下划线宽度可以调整10的数值。
  42.   (setq nent1 (entlast))
  43.   (COMMAND "line" np3 np4 "")               ; 第二条下划线
  44.   (setq nent2 (entlast))
  45.   (COMMAND "CHPROP" nent1 "" "C" "1" ""); 第一条下划线更改为洋红颜色
  46.   (COMMAND "CHPROP" nent2 "" "C" "1" ""); 第二条下划线更改为洋红颜色
  47.   (if (/= r 0.0)                       ; 如果文本不水平则旋转下划线角度
  48.     (progn
  49.       (COMMAND "rotate" nent1 "" p (* 180.0 (/ r pi)))
  50.       (COMMAND "rotate" nent2 "" p (* 180.0 (/ r pi)))
  51.     )
  52.   )
  53.   (setvar "osmode" snap)
  54.   (setvar "clayer" old_lay)               ; 恢复当前图层
  55.   (command ".UNDO" "E")
  56.   (princ)
  57. )
"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2016-6-8 09:47:08 | 显示全部楼层
  1. (defun c:tt (/ ss box ent ent1 h nent1 nent2 np1 np2 np3 np4 old_lay p p1x p1y p2x p2y px py r snap test)
  2.   (setvar "cmdecho" 0) ; 关闭命令响应
  3.   (command ".UNDO" "BE") ; 设置undo起点
  4.   (setq snap (getvar "osmode"))
  5.   (setvar "osmode" 0) ; 关闭捕捉
  6.   (setq old_lay (getvar "clayer")) ; 保存当前图层
  7.   (if (setq ss (ssget '((0 . "*text"))))
  8.     (repeat (setq i (sslength ss))
  9.       (setq ent1 (ssname ss (setq i (1- i))))
  10.       (setq ent (entget ent1))
  11.       (if (= "MTEXT" (cdr (assoc 0 ent))) ; 如选多行文本,则转化为单行文本
  12.         (progn
  13.           (command ".EXPLODE" ent1)
  14.           (setq ent1 (entlast))
  15.           (setq ent (entget ent1))
  16.         )
  17.         (princ)
  18.       )
  19.       (setq p (cdr (assoc 10 ent)) ; 文本基点坐标
  20.         h (cdr (assoc 40 ent)) ; 文本高度
  21.         r (cdr (assoc 50 ent)) ; 文本旋转角度
  22.         test (cdr (assoc 8 ent)) ; 文本所在图层
  23.       )
  24.       (setq box (textbox ent)) ; 文本框坐标
  25.       (setq p1x (car (car box)) ; 文本左下角X坐标
  26.         p1y (car (cdr (car box)))
  27.         p2x (car (car (cdr box))) ; 文本右上角X坐标
  28.         p2y (car (cdr (car (cdr box))))
  29.         px (car p)
  30.         py (car (cdr p))
  31.       )
  32.       ; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
  33.       (setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度,(* h
  34.       ; 0.3)竖直方向距0.3倍字高。
  35.       (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
  36.       (setq np3 (list (- px (* h 0.2)) (- py (* h 0.46)))) ; 第二条线段左端点坐标
  37.       (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.46)) 0.0)) ; 第二条线段右端点坐标
  38.       (setvar "CLAYER" test) ; 文本所在图层设为当前图层
  39.       (command "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h
  40.       ; 10)指第一条下划线宽度为文本高度的0.1倍,如需调整下划线宽度可以调整10的数值。
  41.       (setq nent1 (entlast))
  42.       (command "line" np3 np4 "") ; 第二条下划线
  43.       (setq nent2 (entlast))
  44.       (command "CHPROP" nent1 "" "C" "1" ""); 第一条下划线更改为洋红颜色
  45.       (command "CHPROP" nent2 "" "C" "1" ""); 第二条下划线更改为洋红颜色
  46.       (if (/= r 0.0) ; 如果文本不水平则旋转下划线角度
  47.         (progn
  48.           (command "rotate" nent1 "" p (* 180.0 (/ r pi)))
  49.           (command "rotate" nent2 "" p (* 180.0 (/ r pi)))
  50.         )
  51.       )
  52.     )
  53.   )
  54.   (setvar "osmode" snap)
  55.   (setvar "clayer" old_lay) ; 恢复当前图层
  56.   (command ".UNDO" "E")
  57. )

点评

感谢大神。 使用完改程序后,在当前图中绘制多段线、宽度会变成双线的第一条线的宽度,请问怎么恢复默认宽度。谢谢  发表于 2022-12-16 17:28
 楼主| 发表于 2016-6-8 10:31:22 | 显示全部楼层
1993063 发表于 2016-6-8 09:47

非常好用,谢谢
发表于 2016-6-8 12:31:08 | 显示全部楼层
szx025 发表于 2016-6-7 16:31
非常好用,谢谢

简单的循环处理,楼上应该自己学会
发表于 2016-6-8 15:14:26 | 显示全部楼层
本帖最后由 1993063 于 2016-6-8 02:50 编辑
  1. 另外两种方式:
  2. 一种用MAPCAR +LAMBDA 一种FOREACH 这两种是转表再处理,上面是直接选择集处理

复制代码
发表于 2020-8-11 16:41:08 | 显示全部楼层
对多行文字无效
发表于 2020-8-19 16:45:25 | 显示全部楼层
谢谢分享!               .
发表于 2023-1-18 17:48:43 | 显示全部楼层
(defun c:tt (/ i n pt_bc pt_bl pt_br pt_mc pt_tc pttl pttr roundspace ss1 tbox txtentdata txtentname txtenttype xangle xheight xwidth)
  (setq ss1 (ssget '((0 . "*TEXT"))))
  (if (null ss1)
    (progn
      (princ "\n没有文本实体被选择!")
      (exit)
    )                                        ; end progn
  )                                        ; end if
  (setq n (sslength ss1))
  (if (not (= nil n))                        ; no select objects
    (progn
      (setq i 0)
      (while (< i n)
        (setq txtentname (ssname ss1 i))
        (setq txtentdata (entget txtentname))
        (setq i (+ i 1))
        (setq txtenttype (cdr (assoc 0 txtentdata)))
                                        ; get entity's name:
                                        ; "text" or "mtext"
        (if (= txtenttype "TEXT")        ; this object is simple line text
          (progn
            (vl-cmdf "ucs" "Object" txtentname)
                                        ; 定义用户坐标系到文本的方?
            (setq tbox        (textbox (list (car txtentdata)))
                                        ; must change to a list
                  pt_bl        (car tbox)        ; left bottom point coords
                  pttr        (cadr tbox)        ; right top point coords
                  pttl        (list (car pt_bl) (cadr pttr))
                  pt_br        (list (car pttr) (cadr pt_bl))
            )                                ; end setq
            (setq roundspace (* 0.2 (distance pt_bl pttl)))
            (setq pt_bl (polar pt_bl pi (* roundspace 2)))
            (setq pt_bl (polar pt_bl (* pi 1.5) roundspace))
            (setq pt_br (polar pt_br 0.0 (* roundspace 2)))
            (setq pt_br (polar pt_br (* pi 1.5) roundspace)) ;
            (vl-cmdf "pline"
                     pt_bl
                     "w"
                     (* roundspace 0.25)
                     ""
                     pt_br
                     ""
            )
            (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
            (vl-cmdf "pline"
                     (polar pt_bl (* pi 1.5) (* roundspace 0.6))
                     "w"
                     0
                     ""
                     (polar pt_br (* pi 1.5) (* roundspace 0.6))
                     ""
            )
            (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
            (vl-cmdf "ucs" "p")
          )                                ; end progn
          (progn
            (vl-cmdf "_.JustifyText" txtentname "" "TL")
                                        ; 处理为对对齐模式.
            (setq txtentdata (entget txtentname))
            (setq pttl          (cdr (assoc 10 txtentdata))
                  xwidth  (cdr (assoc 42 txtentdata))
                  xheight (cdr (assoc 43 txtentdata))
                  xangle  (cdr (assoc 50 txtentdata))
                  pt_tc          (polar pttl xangle (* xwidth 0.5))
                  pttr          (polar pttl xangle xwidth)
                  pt_bl          (polar pttl (- xangle (/ pi 2.0)) xheight)
                  pt_bc          (polar pt_bl xangle (* xwidth 0.5))
                  pt_br          (polar pt_bl xangle xwidth)
                  pt_mc          (polar pt_bl
                                 (angle pt_bl pttr)
                                 (/
                                   (distance pt_bl
                                             pttr
                                   )
                                   2.0        ; end
                                 )        ; end angle
                          )                ; end polar
            )                                ; end setq
            (setq roundspace (* 0.2 (distance pt_bl pttl)))
            (setq xangle (cdr (assoc 50 txtentdata)))
            (setq pt_bl (polar pt_bl xangle (- roundspace)))
            (setq
              pt_bl (polar pt_bl (+ xangle (/ pi 2.0)) (- roundspace))
            )
            (setq pt_br (polar pt_br xangle roundspace))
            (setq
              pt_br (polar pt_br (+ xangle (/ pi 2.0)) (- roundspace))
            )
            (setq pttl (polar pttl xangle (- roundspace)))
            (setq pttl (polar pttl (+ xangle (/ pi 2.0)) roundspace))
            (setq pttr (polar pttr xangle roundspace))
            (setq pttr (polar pttr (+ xangle (/ pi 2.0)) roundspace)) ;
            (vl-cmdf "pline" pt_bl "w" (* roundspace 0.25) "" pt_br "")
            (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
            (vl-cmdf "pline"
                     (polar pt_bl (* pi 1.5) (* roundspace 0.6))
                     "w"
                     0
                     ""
                     (polar pt_br (* pi 1.5) (* roundspace 0.6))
                     ""
            )
            (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
                                        ; end command
          )                                ; end progn
        )                                ; end if
      )                                        ; end while
    )                                        ; end progn
  ); end if
  (vl-cmdf "ucs" "W")
  (princ)
)
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-6 00:37 , Processed in 0.201385 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表