文本加下划线程序的完善

szx025

这个文本加下划线程序是网上下载的，很好用，但是它只能单个选择文本，高手可以优化一下吗，改为可以多选文本，这样对于有几个文本同时需要加下划线时，可以提高效率

2. ;;; =================================================================
   
3. ;;; 文本加杨红颜色下划线
   
4. ;;; 作者：langjs   　　　　命令：WTH 　　　　　  日期2011年1月6日
   
5. ;;; =================================================================
   
6. (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)
   
7.   (setq ent1 (car (entsel "\n选择文本：")))
   
8.   (setvar "cmdecho" 0)                       ; 关闭命令响应
   
9.   (command ".UNDO" "BE")               ; 设置undo起点
   
10.   (setq snap (getvar "osmode"))
    
11.   (setvar "osmode" 0)                       ; 关闭捕捉
    
12.   (setq old_lay (getvar "clayer"))     ; 保存当前图层
    
13.   (setq ent (entget ent1))
    
14.   (if (= "MTEXT" (cdr (assoc 0 ent)))  ; 如选多行文本，则转化为单行文本
    
15.     (progn
    
16.       (command ".EXPLODE" ent1)
    
17.       (setq ent1 (entlast))
    
18.       (setq ent (entget ent1))
    
19.     )
    
20.     (princ)
    
21.   )
    
22.   (setq p (cdr (assoc 10 ent))               ; 文本基点坐标
    
23.         h (cdr (assoc 40 ent))               ; 文本高度
    
24.         r (cdr (assoc 50 ent))               ; 文本旋转角度
    
25.         TEST (cdr (assoc 8 ent))       ; 文本所在图层
    
26. 
    
27.   )
    
28.   (setq box (textbox ent))               ; 文本框坐标
    
29.   (setq p1x (car (car box))               ; 文本左下角X坐标
    
30.         p1y (car (cdr (car box)))
    
31.         p2x (car (car (cdr box)))      ; 文本右上角X坐标
    
32.         p2y (car (cdr (car (cdr box))))
    
33.         px (car p)
    
34.         py (car (cdr p))
    
35.   )                                       ; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
    
36.   (setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h
    
37.                                        ; 0.3)竖直方向距0.3倍字高。
    
38.   (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
    
39.   (setq np3 (list (- px (* h 0.2)) (- py (* h 0.46)))) ; 第二条线段左端点坐标
    
40.   (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.46)) 0.0)) ; 第二条线段右端点坐标
    
41.   (SETVAR "CLAYER" TEST)               ; 文本所在图层设为当前图层
    
42.   (COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h
    
43.                                        ; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。
    
44.   (setq nent1 (entlast))
    
45.   (COMMAND "line" np3 np4 "")               ; 第二条下划线
    
46.   (setq nent2 (entlast))
    
47.   (COMMAND "CHPROP" nent1 "" "C" "1" ""); 第一条下划线更改为洋红颜色
    
48.   (COMMAND "CHPROP" nent2 "" "C" "1" ""); 第二条下划线更改为洋红颜色
    
49.   (if (/= r 0.0)                       ; 如果文本不水平则旋转下划线角度
    
50.     (progn
    
51.       (COMMAND "rotate" nent1 "" p (* 180.0 (/ r pi)))
    
52.       (COMMAND "rotate" nent2 "" p (* 180.0 (/ r pi)))
    
53.     )
    
54.   )
    
55.   (setvar "osmode" snap)
    
56.   (setvar "clayer" old_lay)               ; 恢复当前图层
    
57.   (command ".UNDO" "E")
    
58.   (princ)
    
59. )

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

1993063

2. (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)
   
3.   (setvar "cmdecho" 0) ; 关闭命令响应
   
4.   (command ".UNDO" "BE") ; 设置undo起点
   
5.   (setq snap (getvar "osmode"))
   
6.   (setvar "osmode" 0) ; 关闭捕捉
   
7.   (setq old_lay (getvar "clayer")) ; 保存当前图层
   
8.   (if (setq ss (ssget '((0 . "*text"))))
   
9.     (repeat (setq i (sslength ss))
   
10.       (setq ent1 (ssname ss (setq i (1- i))))
    
11.       (setq ent (entget ent1))
    
12.       (if (= "MTEXT" (cdr (assoc 0 ent))) ; 如选多行文本，则转化为单行文本
    
13.         (progn
    
14.           (command ".EXPLODE" ent1)
    
15.           (setq ent1 (entlast))
    
16.           (setq ent (entget ent1))
    
17.         )
    
18.         (princ)
    
19.       )
    
20.       (setq p (cdr (assoc 10 ent)) ; 文本基点坐标
    
21.         h (cdr (assoc 40 ent)) ; 文本高度
    
22.         r (cdr (assoc 50 ent)) ; 文本旋转角度
    
23.         test (cdr (assoc 8 ent)) ; 文本所在图层
    
24.       )
    
25.       (setq box (textbox ent)) ; 文本框坐标
    
26.       (setq p1x (car (car box)) ; 文本左下角X坐标
    
27.         p1y (car (cdr (car box)))
    
28.         p2x (car (car (cdr box))) ; 文本右上角X坐标
    
29.         p2y (car (cdr (car (cdr box))))
    
30.         px (car p)
    
31.         py (car (cdr p))
    
32.       )
    
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.     )
    
54.   )
    
55.   (setvar "osmode" snap)
    
56.   (setvar "clayer" old_lay) ; 恢复当前图层
    
57.   (command ".UNDO" "E")
    
58. )

(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) <br />   (setvar "cmdecho" 0) ; 关闭命令响应<br />   (command ".UNDO" "BE") ; 设置undo起点<br />   (setq snap (getvar "osmode"))<br />   (setvar "osmode" 0) ; 关闭捕捉<br />   (setq old_lay (getvar "clayer")) ; 保存当前图层<br />   (if (setq ss (ssget '((0 . "*text"))))<br />     (repeat (setq i (sslength ss))<br />       (setq ent1 (ssname ss (setq i (1- i))))<br />       (setq ent (entget ent1))<br />       (if (= "MTEXT" (cdr (assoc 0 ent))) ; 如选多行文本，则转化为单行文本<br />         (progn<br />           (command ".EXPLODE" ent1)<br />           (setq ent1 (entlast))<br />           (setq ent (entget ent1))<br />         )<br />         (princ)<br />       )<br />       (setq p (cdr (assoc 10 ent)) ; 文本基点坐标<br />         h (cdr (assoc 40 ent)) ; 文本高度<br />         r (cdr (assoc 50 ent)) ; 文本旋转角度<br />         test (cdr (assoc 8 ent)) ; 文本所在图层<br />       )<br />       (setq box (textbox ent)) ; 文本框坐标<br />       (setq p1x (car (car box)) ; 文本左下角X坐标<br />         p1y (car (cdr (car box)))<br />         p2x (car (car (cdr box))) ; 文本右上角X坐标<br />         p2y (car (cdr (car (cdr box))))<br />         px (car p)<br />         py (car (cdr p))<br />       )<br />       ; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数<br />       (setq np1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h<br />       ; 0.3)竖直方向距0.3倍字高。<br />       (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标<br />       (setq np3 (list (- px (* h 0.2)) (- py (* h 0.46)))) ; 第二条线段左端点坐标<br />       (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.46)) 0.0)) ; 第二条线段右端点坐标<br />       (setvar "CLAYER" test) ; 文本所在图层设为当前图层<br />       (command "pline" np1 "w" (/ h 10) (/ h 10) np2 "") ; 第一条下划线。(/ h<br />       ; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。<br />       (setq nent1 (entlast))<br />       (command "line" np3 np4 "") ; 第二条下划线<br />       (setq nent2 (entlast))<br />       (command "CHPROP" nent1 "" "C" "1" ""); 第一条下划线更改为洋红颜色<br />       (command "CHPROP" nent2 "" "C" "1" ""); 第二条下划线更改为洋红颜色<br />       (if (/= r 0.0) ; 如果文本不水平则旋转下划线角度<br />         (progn<br />           (command "rotate" nent1 "" p (* 180.0 (/ r pi)))<br />           (command "rotate" nent2 "" p (* 180.0 (/ r pi)))<br />         )<br />       )<br />     )<br />   )<br />   (setvar "osmode" snap)<br />   (setvar "clayer" old_lay) ; 恢复当前图层<br />   (command ".UNDO" "E")<br /> )

szx025

1993063 发表于 2016-6-8 09:47

非常好用，谢谢

1993063

szx025 发表于 2016-6-7 16:31
非常好用，谢谢

简单的循环处理,楼上应该自己学会

1993063

1. 另外两种方式:
   
2. 一种用MAPCAR +LAMBDA 一种FOREACH 这两种是转表再处理,上面是直接选择集处理
   
3. 
   

复制代码

chenry676

对多行文字无效

376394482

谢谢分享！               .

zj20190405

(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)
)