（已完成）[编程申请]：求给选择的文字（TEXT）加下画线的程序...

marting

谢谢晓东和EACHY，这么快就把“读剪切板的程序”写好了，用后感觉真的不错，以后有什么建议我在贴上来。

我再贴个申请吧，别嫌我烦啊：）

还是字符串的，能写个程序把TEXT加上下滑线吗？

谢谢！

XDSoft

写好了两个程序，一个是加下划线，另个是删除下划线，请试用...

2. 
   
3. [FONT=courier new]
   
4. 
   
5. ;|
   
6.    命令：txt_setuline
   
7.    
   
8.    功能：给选取的TEXT文字加下滑线（过滤掉前后空格）
   
9.    
   
10.    说明：1、下划线到文字底距离是字高的八分之一
    
11.         2、下划线所在层是LAYERDEF.DAT中定义的“公共文字”对应的英文层名。
    
12. 
    
13.         程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
    
14.         LISP目录，自己加入到菜单里面就可以非常方便的使用了。
    
15.         关于程序的建议请到“晓东CAD空间-编程申请”论坛
    
16.         [url]http://www.xdcad.net/forum留言[/url]         
    
17. |;
    
18. 
    
19. (defun c:txt_setuline (/ ss e ang basept box thigh lyr)
    
20.   (xdrx_begin)
    
21.   (xdrx_ucson)
    
22.   (setq lyr (xdrx_getlyrname "公共文字"))
    
23.   (while (progn
    
24.            (prompt "\n请选取要加下划线的文字<退出>:")
    
25.            (setq ss (ssget '((0 . "text"))))
    
26.          )
    
27.     (xdrx_setsstodb ss 0)
    
28.     (while (setq e (xdrx_getentdata 0))
    
29.       (setq ang (xdrx_getentdxf 50)
    
30.             basept (xdrx_getentdxf 10)
    
31.             thigh (xdrx_getentdxf 40)
    
32.       )
    
33.       (if (not (equal ang 0.0 1e-5))
    
34.         (progn
    
35.           (command "._rotate" e "" basept (angtos (- ang)))
    
36.           (setq box (xdrx_entity_box e)
    
37.                 box (apply
    
38.                       'xdrx_pointsoffset
    
39.                       (cons (/ thigh 8) box)
    
40.                     )
    
41.                 box (apply
    
42.                       'xdrx_pointsrotate
    
43.                       (cons basept (cons ang box))
    
44.                     )
    
45.           )
    
46.           (command "._rotate" e "" basept (angtos ang))
    
47.         )
    
48.         (progn
    
49.           (setq box (xdrx_entity_box e)
    
50.                 box (apply
    
51.                       'xdrx_pointsoffset
    
52.                       (cons (/ thigh 8) box)
    
53.                     )
    
54.           )
    
55.         )
    
56.       )
    
57.       (xdrx_line1 (car box) (cadr box))
    
58.       (xdrx_setenttodb (entlast))
    
59.       (xdrx_modent 8 lyr 62 9)
    
60.     )
    
61.   )
    
62.   (xdrx_ucsoff)
    
63.   (xdrx_end)
    
64.   (princ)
    
65. )
    
66. ;|
    
67.   命令：txt_ruline
    
68.   
    
69.   功能：删除选择的文字下划线
    
70. 
    
71.         程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
    
72.         LISP目录，自己加入到菜单里面就可以非常方便的使用了。
    
73.         关于程序的建议请到“晓东CAD空间-编程申请”论坛
    
74.         [url]http://www.xdcad.net/forum留言[/url]         
    
75.   
    
76. |;
    
77. (defun c:txt_ruline (/ ss lyr)
    
78.   (xdrx_begin)
    
79.   (setq lyr (xdrx_getlyrname "公共文字"))
    
80.   (prompt "\n请选取要删除的文字下划线<所有>:")
    
81.   (if (not (setq ss (ssget (list '(0 . "line") '(62 . 9) (cons 8 lyr
    
82.                                                          )
    
83.                            )
    
84.                     )
    
85.            )
    
86.       )
    
87.     (setq ss (ssget "x" (list '(0 . "line") '(62 . 9) (cons 8 lyr))))
    
88.   )
    
89.   (command "._erase" ss "")
    
90.   (xdrx_end)
    
91.   (princ)
    
92. )
    
93. 
    
94. [/FONT]

<br /> [FONT=courier new]<br /> <br /> ;|<br />    命令：txt_setuline<br />    <br />    功能：给选取的TEXT文字加下滑线（过滤掉前后空格）<br />    <br />    说明：1、下划线到文字底距离是字高的八分之一<br />         2、下划线所在层是LAYERDEF.DAT中定义的“公共文字”对应的英文层名。<br /> <br />         程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的<br />         LISP目录，自己加入到菜单里面就可以非常方便的使用了。<br />         关于程序的建议请到“晓东CAD空间-编程申请”论坛<br />         [url]http://www.xdcad.net/forum留言[/url]         <br /> |;<br /> <br /> (defun c:txt_setuline (/ ss e ang basept box thigh lyr)<br />   (xdrx_begin)<br />   (xdrx_ucson)<br />   (setq lyr (xdrx_getlyrname "公共文字"))<br />   (while (progn<br />            (prompt "\n请选取要加下划线的文字<退出>:")<br />            (setq ss (ssget '((0 . "text"))))<br />          )<br />     (xdrx_setsstodb ss 0)<br />     (while (setq e (xdrx_getentdata 0))<br />       (setq ang (xdrx_getentdxf 50)<br />             basept (xdrx_getentdxf 10)<br />             thigh (xdrx_getentdxf 40)<br />       )<br />       (if (not (equal ang 0.0 1e-5))<br />         (progn<br />           (command "._rotate" e "" basept (angtos (- ang)))<br />           (setq box (xdrx_entity_box e)<br />                 box (apply<br />                       'xdrx_pointsoffset<br />                       (cons (/ thigh 8) box)<br />                     )<br />                 box (apply<br />                       'xdrx_pointsrotate<br />                       (cons basept (cons ang box))<br />                     )<br />           )<br />           (command "._rotate" e "" basept (angtos ang))<br />         )<br />         (progn<br />           (setq box (xdrx_entity_box e)<br />                 box (apply<br />                       'xdrx_pointsoffset<br />                       (cons (/ thigh 8) box)<br />                     )<br />           )<br />         )<br />       )<br />       (xdrx_line1 (car box) (cadr box))<br />       (xdrx_setenttodb (entlast))<br />       (xdrx_modent 8 lyr 62 9)<br />     )<br />   )<br />   (xdrx_ucsoff)<br />   (xdrx_end)<br />   (princ)<br /> )<br /> ;|<br />   命令：txt_ruline<br />   <br />   功能：删除选择的文字下划线<br /> <br />         程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的<br />         LISP目录，自己加入到菜单里面就可以非常方便的使用了。<br />         关于程序的建议请到“晓东CAD空间-编程申请”论坛<br />         [url]http://www.xdcad.net/forum留言[/url]         <br />   <br /> |;<br /> (defun c:txt_ruline (/ ss lyr)<br />   (xdrx_begin)<br />   (setq lyr (xdrx_getlyrname "公共文字"))<br />   (prompt "\n请选取要删除的文字下划线<所有>:")<br />   (if (not (setq ss (ssget (list '(0 . "line") '(62 . 9) (cons 8 lyr<br />                                                          )<br />                            )<br />                     )<br />            )<br />       )<br />     (setq ss (ssget "x" (list '(0 . "line") '(62 . 9) (cons 8 lyr))))<br />   )<br />   (command "._erase" ss "")<br />   (xdrx_end)<br />   (princ)<br /> )<br /> <br /> [/FONT]

pxt2001

这样可以更简单：AutoCAD中已经有了这个功能，在需要加下划线的文字前后都加上%%u，就能给指定文字加下划线！或者在某个字符前加%%u，则该字符后所有的文字都加下划线。

Jerry541

这样当然没有自己编的程序简单，只要点一下就可以在文字下直接加上去了，不用一个个去加%%U了。

zhy_yi

确实非常方便

海豚

最初由 pxt2001 发布
[B]这样可以更简单：AutoCAD中已经有了这个功能，在需要加下划线的文字前后都加上%%u，就能给指定文字加下划线！或者在某个字符前加%%u，则该字符后所有的文字都加下划线。 [/B]

我觉得还是有这个必要，因为有时候想从下划线引一根线到实体，%%U就比较麻烦了，如果使用LEAD，则下划线必须与引线同颜色，也是不好。我先下载试用。谢谢XD。

1.另外由于我有时候希望下划线的颜色能否设一个变量，如果需要可以设置，如果不设置，原变量存在，则按上次变量，不不存在，则按随层，应如何修改程序，是否需要增加全局变量。
2.我觉下划线到文字底距离是字高的八分之一太小了，所以为改为了子高的1/5.
3.我觉得下划线比文字两端的延长不够，但不知道调整那一个参数才可以延长，希望能指点（我对LISP连入门水平都没有达到）
4.下划线的层如果我已经确定，是否直接按下面的程序，换成相应的层名即可（我把LAYERDEF.DAT中加了一句“下划  T2  2"，按并把下面程序的"公共文字"全部改为”下划“，但出现的层名字为"T"，颜色为7，并不是我希望的T2，是否名字一定要为英文）。

[PHP]

;|
   命令：txt_setuline
   
   功能：给选取的TEXT文字加下滑线（过滤掉前后空格）
   
   说明：1、下划线到文字底距离是字高的5分之一
        2、下划线所在层是LAYERDEF.DAT中定义的“公共文字”对应的英文层名。

        程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
        LISP目录，自己加入到菜单里面就可以非常方便的使用了。
        关于程序的建议请到“晓东CAD空间-编程申请”论坛
        http://www.xdcad.net/forum留言         
|;

(defun c:txt_setuline (/ ss e ang basept box thigh lyr)
  (xdrx_begin)
  (xdrx_ucson)
  (setq lyr (xdrx_getlyrname "公共文字"))  
;能否直接把该句改为“  (setq lyr ("T2"))  ”
  (while (progn
           (prompt "\n请选取要加下划线的文字<退出>:")
           (setq ss (ssget '((0 . "text"))))
         )
    (xdrx_setsstodb ss 0)
    (while (setq e (xdrx_getentdata 0))
      (setq ang (xdrx_getentdxf 50)
            basept (xdrx_getentdxf 10)
            thigh (xdrx_getentdxf 40)
      )
      (if (not (equal ang 0.0 1e-5))
        (progn
          (command "._rotate" e "" basept (angtos (- ang)))
          (setq box (xdrx_entity_box e)
                box (apply
                      'xdrx_pointsoffset
                      (cons (/ thigh 5) box)
                    )
                box (apply
                      'xdrx_pointsrotate
                      (cons basept (cons ang box))
                    )
          )
          (command "._rotate" e "" basept (angtos ang))
        )
        (progn
          (setq box (xdrx_entity_box e)
                box (apply
                      'xdrx_pointsoffset
                      (cons (/ thigh 5) box)
                    )
          )
        )
      )
      (xdrx_line1 (car box) (cadr box))
      (xdrx_setenttodb (entlast))
      (xdrx_modent 8 lyr 62 9) ;9是否能设全局变量，自由调整，对删除有没有影响
    )
  )
  (xdrx_ucsoff)
  (xdrx_end)
  (princ)
)
;|
  命令：txt_ruline
  
  功能：删除选择的文字下划线

        程序配合XDRX_API build 20630＋版本使用，朋友们可以把这个LISP拷贝到“晓东工具箱”的安装的
        LISP目录，自己加入到菜单里面就可以非常方便的使用了。
        关于程序的建议请到“晓东CAD空间-编程申请”论坛
        http://www.xdcad.net/forum留言         
  
|;
(defun c:txt_ruline (/ ss lyr)
  (xdrx_begin)
  (setq lyr (xdrx_getlyrname "公共文字"))
;能否直接把该句改为“  (setq lyr ("T2"))  ”
  (prompt "\n请选取要删除的文字下划线<所有>:")
  (if (not (setq ss (ssget (list '(0 . "line") '(62 . 9) (cons 8 lyr
                                                         )
                           )
                    )
           )
      )
    (setq ss (ssget "x" (list '(0 . "line") '(62 . 9) (cons 8 lyr))))
  )
  (command "._erase" ss "")
  (xdrx_end)
  (princ)
)
[/PHP]