[LISP程序]：应网友要求把文字加删除线改为加双下划线

LUCAS

;;;應網友要求把文字加删除线改一下
;;;功能:文字加双下划线

2. 
   
3. (defun C:MTT (/              HOLDECHO              HOLDWID HOLDOSMODE      HOLDCLAYER
   
4.               SS      TEXTM   TEXTM1  M10     M40     M42     M43
   
5.               M50     M71     PT1     PT2     PT3     PT4     PT5
   
6.               PT6     PT7     PT8     PT9     RT      TB      DIST
   
7.               DIST1   D              ANG
   
8.              )
   
9.   (command "_.UNDO" "BE")
   
10.   (setq HOLDOSMODE (getvar "OSMODE"))
    
11.   (setq HOLDCLAYER (getvar "CLAYER"))
    
12.   (setq HOLDECHO (getvar "CMDECHO"))
    
13.   (setq HOLDWID (getvar "PLINEWID"))
    
14.   (setvar "CMDECHO" 0)
    
15.   (setvar "OSMODE" 0)
    
16.   (if (= (tblsearch "LAYER" "DIM") NIL)
    
17.     (command "_.layer" "m"         "dim"           "c"             "cyan"
    
18.              ""               "lt"         "continuous"             ""
    
19.              ""
    
20.             )
    
21.   )
    
22.   (setvar "CLAYER" HOLDCLAYER)
    
23.   (while (= TEXTM1 NIL)
    
24.     (setq TEXTM1 (car (nentsel "\n请点选文字加双下划线: ")))
    
25.     (if        (/= TEXTM1 NIL)
    
26.       (progn
    
27.         (setq TEXTM (entget TEXTM1))
    
28.         (if (and (/= "MTEXT" (cdr (assoc 0 TEXTM)))
    
29.                  (/= "TEXT" (cdr (assoc 0 TEXTM)))
    
30.             )
    
31.           (progn
    
32.             (setq TEXTM1 NIL)
    
33.             (prompt (strcat "\n点选对象为" (cdr (assoc 0 TEXTM))))
    
34.           )
    
35.         )
    
36.       )
    
37.     )
    
38.   )
    
39.   (cond
    
40.     ((= "MTEXT" (cdr (assoc 0 TEXTM)))
    
41.      (command "_.ucs" "W")
    
42.      (setq M10 (cdr (assoc 10 TEXTM)))
    
43.      (setq M40 (cdr (assoc 40 TEXTM)))
    
44.      (setq M42 (cdr (assoc 42 TEXTM)))
    
45.      (setq M43 (cdr (assoc 43 TEXTM)))
    
46.      (setq M50 (cdr (assoc 50 TEXTM)))
    
47.      (setq M71 (cdr (assoc 71 TEXTM)))
    
48.      (setq PT9 (list (+ (car M10) M42) (cadr M10) (caddr M10)))
    
49.      (setq PT3 (list (car PT9) (+ (cadr PT9) M43) (caddr PT9)))
    
50.      (setq PT1 (list (car M10) (+ (cadr M10) M43) (caddr M10)))
    
51.      (setq PT8 (list (+ (car M10) (/ M42 2)) (cadr M10) (caddr M10)))
    
52.      (setq PT4 (list (car M10) (+ (cadr M10) (/ M43 2)) (caddr M10)))
    
53.      (setq PT2 (list (+ (car M10) (/ M42 2))
    
54.                      (+ (cadr M10) M43)
    
55.                      (caddr M10)
    
56.                )
    
57.      )
    
58.      (setq PT6 (list (+ (car M10) M42)
    
59.                      (+ (cadr M10) (/ M43 2))
    
60.                      (caddr M10)
    
61.                )
    
62.      )
    
63.      (setq SS (ssadd))
    
64.      (setq ANG (angle PT1 M10))
    
65.      (setq M101 (polar M10 (+ ANG pi) (* M40 0.05)))
    
66.      ;;(setq M101 (polar M10 ANG (* M40 0.05)))那是第一点与字距离方向不同
    
67.      ;;计算第一点与字距离(* M40 0.05),其实对每种字体会有误差,可自行修正
    
68.      (setq PT91 (polar PT9 (+ ANG pi) (* M40 0.05)))
    
69.      ;;(setq PT91 (polar PT9 ANG (* M40 0.05)))那是第一点与字距离方向不同
    
70.      ;;计算第二点与字距离(* M40 0.05),其实对每种字体会有误差,可自行修正
    
71.      (command "_.PLINE"
    
72.               M101
    
73.               "W"
    
74.               (* M40 (/ 3 40.0))
    
75.               ""
    
76.               PT91
    
77.               "W"
    
78.               0
    
79.               ""
    
80.               ""
    
81.      )
    
82.      ;;计算线宽(* M40 (/ 3 40.0))
    
83.      (ssadd (entlast) SS)
    
84.      (command "_.MOVE"
    
85.               (entlast)
    
86.               ""
    
87.               "0,0"
    
88.               (polar '(0 0) ANG (* M40 (/ 3 16.0)))
    
89.               ;;第一条线与字的移动距离,M40=字高
    
90.      )
    
91.      (command "_.LINE" M101 PT91 "")
    
92.      (command "_.MOVE"
    
93.               (entlast)
    
94.               ""
    
95.               "0,0"
    
96.               (polar '(0 0) ANG (* M40 (/ 26 80.0)))
    
97.               ;;第二条线与字的移动距离,M40=字高
    
98.      )
    
99.      (ssadd (entlast) SS)
    
100.      (setq PT5 (inters M10 PT3 PT9 PT1))
     
101.      (cond
     
102.        ((= 1 M71) (command "._move" SS "" PT1 M10)) ;1 = Top left
     
103.        ((= 2 M71) (command "._move" SS "" PT2 M10)) ;2 = Top center
     
104.        ((= 3 M71) (command "._move" SS "" PT3 M10)) ;3 = Top right
     
105.        ((= 4 M71) (command "._move" SS "" PT4 M10)) ;4 = Middle left
     
106.        ((= 5 M71) (command "._move" SS "" PT5 M10)) ;5 = Middle center
     
107.        ((= 6 M71) (command "._move" SS "" PT6 M10)) ;6 = Middle right
     
108. ;;;    ((= 7 M71) (command "._move" SS "" M10 M10)) ;7 = Bottom left
     
109.        ((= 8 M71) (command "._move" SS "" PT8 M10)) ;8 = Bottom center
     
110.        ((= 9 M71) (command "._move" SS "" PT9 M10)) ;9 = Bottom right
     
111.      )
     
112.      (command "_.ROTATE" SS "" M10 (/ (* 180 M50) pi))
     
113.      (command "_.CHANGE" SS "" "P" "LA" "DIM" "C" 6 "")
     
114.      ;;把线移至DIM层,COLOR为紫色
     
115.      (setq DIST (* M40 1.66))
     
116.      (setq DIST1 (fix (/ M43 DIST)))
     
117.      (setq D 1)
     
118.      (repeat DIST1
     
119.        (command        "_.COPY"
     
120.                 SS
     
121.                 ""
     
122.                 M10
     
123.                 (polar M10 (+ M50 (/ pi 2)) (* DIST D))
     
124.        )
     
125.        (setq D (+ 1 D))
     
126.      )
     
127.      (command "_.ucs" "p")
     
128.     )
     
129.     ((= "TEXT" (cdr (assoc 0 TEXTM)))
     
130.      (command "_.ucs" "Object" TEXTM1)
     
131.      (setq TB (textbox (list (cons -1 TEXTM1))))
     
132.      (setq PT1 (car TB)
     
133.            PT2 (cadr TB)
     
134.            PT3 (list (car PT1) (cadr PT2))
     
135.            PT4 (list (car PT2) (cadr PT1))
     
136.      )
     
137.      (setq DIST (cdr (assoc 40 TEXTM)))
     
138.      ;;取出文字高度
     
139.      (setq ANG (angle PT3 PT1))
     
140.      (setq SS (ssadd))
     
141.      (setq PT1 (polar PT1 (+ ANG pi) (* DIST 0.05)))
     
142.      ;;(setq PT1 (polar PT1 ANG (* DIST 0.05)))那是第一点与字距离方向不同
     
143.      ;;计算第一点与字距离(* DIST 0.05),其实对每种字体会有误差,可自行修正
     
144.      (setq PT4 (polar PT4 (+ ANG pi) (* DIST 0.05)))
     
145.      ;;(setq PT4 (polar PT4 ANG (* DIST 0.05)))那是第一点与字距离方向不同
     
146.      ;;计算第二点与字距离(* DIST 0.05),其实对每种字体会有误差,可自行修正
     
147.      (command "_.PLINE"
     
148.               PT1
     
149.               "W"
     
150.               (* DIST (/ 3 40.0))
     
151.               ""
     
152.               PT4
     
153.               "W"
     
154.               0
     
155.               ""
     
156.               ""
     
157.      )
     
158.      ;;计算线宽(* DIST (/ 3 40.0))
     
159.      (ssadd (entlast) SS)
     
160.      (command "_.MOVE"
     
161.               (entlast)
     
162.               ""
     
163.               "0,0"
     
164.               (polar '(0 0) ANG (* DIST (/ 3 16.0)))
     
165.               ;;第一条线与字的移动距离,DIST=字高
     
166.      )
     
167.      (command "_.LINE" PT1 PT4 "")
     
168.      (command "_.MOVE"
     
169.               (entlast)
     
170.               ""
     
171.               "0,0"
     
172.               (polar '(0 0) ANG (* DIST (/ 26 80.0)))
     
173.               ;;第二条线与字的移动距离,DIST=字高
     
174.      )
     
175.      (ssadd (entlast) SS)
     
176.      (command "_.CHANGE" SS "" "P" "LA" "DIM" "C" 6 "")
     
177.      ;;把线移至DIM层,COLOR为紫色
     
178.      (command "_.ucs" "p")
     
179.     )
     
180.   )
     
181.   (setvar "PLINEWID" HOLDWID)
     
182.   (setvar "OSMODE" HOLDOSMODE)
     
183.   (setvar "CMDECHO" HOLDECHO)
     
184.   (command "_.UNDO" "END")
     
185.   (princ)
     
186. )
     
187. 
     

<br /> (defun C:MTT (/              HOLDECHO              HOLDWID HOLDOSMODE      HOLDCLAYER<br />               SS      TEXTM   TEXTM1  M10     M40     M42     M43<br />               M50     M71     PT1     PT2     PT3     PT4     PT5<br />               PT6     PT7     PT8     PT9     RT      TB      DIST<br />               DIST1   D              ANG<br />              )<br />   (command "_.UNDO" "BE")<br />   (setq HOLDOSMODE (getvar "OSMODE"))<br />   (setq HOLDCLAYER (getvar "CLAYER"))<br />   (setq HOLDECHO (getvar "CMDECHO"))<br />   (setq HOLDWID (getvar "PLINEWID"))<br />   (setvar "CMDECHO" 0)<br />   (setvar "OSMODE" 0)<br />   (if (= (tblsearch "LAYER" "DIM") NIL)<br />     (command "_.layer" "m"         "dim"           "c"             "cyan"<br />              ""               "lt"         "continuous"             ""<br />              ""<br />             )<br />   )<br />   (setvar "CLAYER" HOLDCLAYER)<br />   (while (= TEXTM1 NIL)<br />     (setq TEXTM1 (car (nentsel "\n请点选文字加双下划线: ")))<br />     (if        (/= TEXTM1 NIL)<br />       (progn<br />         (setq TEXTM (entget TEXTM1))<br />         (if (and (/= "MTEXT" (cdr (assoc 0 TEXTM)))<br />                  (/= "TEXT" (cdr (assoc 0 TEXTM)))<br />             )<br />           (progn<br />             (setq TEXTM1 NIL)<br />             (prompt (strcat "\n点选对象为" (cdr (assoc 0 TEXTM))))<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (cond<br />     ((= "MTEXT" (cdr (assoc 0 TEXTM)))<br />      (command "_.ucs" "W")<br />      (setq M10 (cdr (assoc 10 TEXTM)))<br />      (setq M40 (cdr (assoc 40 TEXTM)))<br />      (setq M42 (cdr (assoc 42 TEXTM)))<br />      (setq M43 (cdr (assoc 43 TEXTM)))<br />      (setq M50 (cdr (assoc 50 TEXTM)))<br />      (setq M71 (cdr (assoc 71 TEXTM)))<br />      (setq PT9 (list (+ (car M10) M42) (cadr M10) (caddr M10)))<br />      (setq PT3 (list (car PT9) (+ (cadr PT9) M43) (caddr PT9)))<br />      (setq PT1 (list (car M10) (+ (cadr M10) M43) (caddr M10)))<br />      (setq PT8 (list (+ (car M10) (/ M42 2)) (cadr M10) (caddr M10)))<br />      (setq PT4 (list (car M10) (+ (cadr M10) (/ M43 2)) (caddr M10)))<br />      (setq PT2 (list (+ (car M10) (/ M42 2))<br />                      (+ (cadr M10) M43)<br />                      (caddr M10)<br />                )<br />      )<br />      (setq PT6 (list (+ (car M10) M42)<br />                      (+ (cadr M10) (/ M43 2))<br />                      (caddr M10)<br />                )<br />      )<br />      (setq SS (ssadd))<br />      (setq ANG (angle PT1 M10))<br />      (setq M101 (polar M10 (+ ANG pi) (* M40 0.05)))<br />      ;;(setq M101 (polar M10 ANG (* M40 0.05)))那是第一点与字距离方向不同<br />      ;;计算第一点与字距离(* M40 0.05),其实对每种字体会有误差,可自行修正<br />      (setq PT91 (polar PT9 (+ ANG pi) (* M40 0.05)))<br />      ;;(setq PT91 (polar PT9 ANG (* M40 0.05)))那是第一点与字距离方向不同<br />      ;;计算第二点与字距离(* M40 0.05),其实对每种字体会有误差,可自行修正<br />      (command "_.PLINE"<br />               M101<br />               "W"<br />               (* M40 (/ 3 40.0))<br />               ""<br />               PT91<br />               "W"<br />               0<br />               ""<br />               ""<br />      )<br />      ;;计算线宽(* M40 (/ 3 40.0))<br />      (ssadd (entlast) SS)<br />      (command "_.MOVE"<br />               (entlast)<br />               ""<br />               "0,0"<br />               (polar '(0 0) ANG (* M40 (/ 3 16.0)))<br />               ;;第一条线与字的移动距离,M40=字高<br />      )<br />      (command "_.LINE" M101 PT91 "")<br />      (command "_.MOVE"<br />               (entlast)<br />               ""<br />               "0,0"<br />               (polar '(0 0) ANG (* M40 (/ 26 80.0)))<br />               ;;第二条线与字的移动距离,M40=字高<br />      )<br />      (ssadd (entlast) SS)<br />      (setq PT5 (inters M10 PT3 PT9 PT1))<br />      (cond<br />        ((= 1 M71) (command "._move" SS "" PT1 M10)) ;1 = Top left<br />        ((= 2 M71) (command "._move" SS "" PT2 M10)) ;2 = Top center<br />        ((= 3 M71) (command "._move" SS "" PT3 M10)) ;3 = Top right<br />        ((= 4 M71) (command "._move" SS "" PT4 M10)) ;4 = Middle left<br />        ((= 5 M71) (command "._move" SS "" PT5 M10)) ;5 = Middle center<br />        ((= 6 M71) (command "._move" SS "" PT6 M10)) ;6 = Middle right<br /> ;;;    ((= 7 M71) (command "._move" SS "" M10 M10)) ;7 = Bottom left<br />        ((= 8 M71) (command "._move" SS "" PT8 M10)) ;8 = Bottom center<br />        ((= 9 M71) (command "._move" SS "" PT9 M10)) ;9 = Bottom right<br />      )<br />      (command "_.ROTATE" SS "" M10 (/ (* 180 M50) pi))<br />      (command "_.CHANGE" SS "" "P" "LA" "DIM" "C" 6 "")<br />      ;;把线移至DIM层,COLOR为紫色<br />      (setq DIST (* M40 1.66))<br />      (setq DIST1 (fix (/ M43 DIST)))<br />      (setq D 1)<br />      (repeat DIST1<br />        (command        "_.COPY"<br />                 SS<br />                 ""<br />                 M10<br />                 (polar M10 (+ M50 (/ pi 2)) (* DIST D))<br />        )<br />        (setq D (+ 1 D))<br />      )<br />      (command "_.ucs" "p")<br />     )<br />     ((= "TEXT" (cdr (assoc 0 TEXTM)))<br />      (command "_.ucs" "Object" TEXTM1)<br />      (setq TB (textbox (list (cons -1 TEXTM1))))<br />      (setq PT1 (car TB)<br />            PT2 (cadr TB)<br />            PT3 (list (car PT1) (cadr PT2))<br />            PT4 (list (car PT2) (cadr PT1))<br />      )<br />      (setq DIST (cdr (assoc 40 TEXTM)))<br />      ;;取出文字高度<br />      (setq ANG (angle PT3 PT1))<br />      (setq SS (ssadd))<br />      (setq PT1 (polar PT1 (+ ANG pi) (* DIST 0.05)))<br />      ;;(setq PT1 (polar PT1 ANG (* DIST 0.05)))那是第一点与字距离方向不同<br />      ;;计算第一点与字距离(* DIST 0.05),其实对每种字体会有误差,可自行修正<br />      (setq PT4 (polar PT4 (+ ANG pi) (* DIST 0.05)))<br />      ;;(setq PT4 (polar PT4 ANG (* DIST 0.05)))那是第一点与字距离方向不同<br />      ;;计算第二点与字距离(* DIST 0.05),其实对每种字体会有误差,可自行修正<br />      (command "_.PLINE"<br />               PT1<br />               "W"<br />               (* DIST (/ 3 40.0))<br />               ""<br />               PT4<br />               "W"<br />               0<br />               ""<br />               ""<br />      )<br />      ;;计算线宽(* DIST (/ 3 40.0))<br />      (ssadd (entlast) SS)<br />      (command "_.MOVE"<br />               (entlast)<br />               ""<br />               "0,0"<br />               (polar '(0 0) ANG (* DIST (/ 3 16.0)))<br />               ;;第一条线与字的移动距离,DIST=字高<br />      )<br />      (command "_.LINE" PT1 PT4 "")<br />      (command "_.MOVE"<br />               (entlast)<br />               ""<br />               "0,0"<br />               (polar '(0 0) ANG (* DIST (/ 26 80.0)))<br />               ;;第二条线与字的移动距离,DIST=字高<br />      )<br />      (ssadd (entlast) SS)<br />      (command "_.CHANGE" SS "" "P" "LA" "DIM" "C" 6 "")<br />      ;;把线移至DIM层,COLOR为紫色<br />      (command "_.ucs" "p")<br />     )<br />   )<br />   (setvar "PLINEWID" HOLDWID)<br />   (setvar "OSMODE" HOLDOSMODE)<br />   (setvar "CMDECHO" HOLDECHO)<br />   (command "_.UNDO" "END")<br />   (princ)<br /> )<br /> <br />

cy956

用textbox能简化些....

梦断江南

把%%U加到文字的前面即可。

申士

LUCAS兄，没想到这么快就改好了，还加了注释，太让小弟感动了...
:2 :2 :2 :2

zqb05

楼主好东西

yaya-54

以前我都是用多线手画的。谢谢了

xiaxiang

我想要，给我一份

tianquan3

谢谢分享

ycao

程序比较有用。如果程序能做到添加下划线后文字长度改变了，添加的下划线自动改变长度那就更好了。

lmt112233

每次只能選一行，能否一次選多行。謝謝！

eriol

很好用！ 不知道怎么修改线宽这些，想把线宽，线间距改为固定的

chen7560152

好用哈，想知道如何是下划线左右两边凸出去对齐点50呢，该怎么设置呢