求为文字添加标题线的lisp程序

ryujacky

文字下面两条线，一条宽的一条细的.
谢谢!!

spp_wall

自己搜索 论坛有！！！

ryujacky

找了半天没找到才发帖问的，不知道这个东西应该怎么称呼? 是不是我叫的不对，不是标题线?

819534890

我贴一个收集的简单的，是单线，自己改为双线就行。

2. (defun c:lsp_40()
   
3.     (initget "T B A")
   
4.     (setq typ (getkword "\n画线型式 [T顶线,B底线,A上下线] <B>: "))
   
5.     (if (null typ) (setq typ "B"))
   
6.     (setq dd (getdist "\n字与线间距 <2>: "))
   
7.     (if (null dd) (setq dd 2.0))
   
8.     (setq ss (ssget))
   
9.     (setq i 0)
   
10.     (repeat (sslength ss)
    
11.        (setq ssn (ssname ss i))
    
12.        (setq ssdata (entget ssn))
    
13.        (setq key (cdr (assoc 0 ssdata)))
    
14.        (if (= key "TEXT")
    
15.           (progn
    
16.              (command "ucs" "e" ssn)
    
17.              (setq box (textbox ssdata))
    
18.              (setq p1 (car box))
    
19.              (setq p3 (cadr box))
    
20.              (setq p2 (list (car p3) (cadr p1)))
    
21.              (setq p4 (list (car p1) (cadr p3)))
    
22.              (setq ang (angle p1 p4))
    
23.              (setq ee (entlast))
    
24.              (cond ((= typ "T") (command "line" (polar p4 ang dd) (polar p3 ang dd) ""))
    
25.                    ((= typ "B") (command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))
    
26.                    ((= typ "A") (command "line" (polar p4 ang dd) (polar p3 ang dd) "")
    
27.                                 (command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))
    
28.              )   
    
29.           )   
    
30.         )
    
31.         (setq i (1+ i))
    
32.      )
    
33.      (command "ucs" "")
    
34.      (prin1)
    
35. )  
    

(defun c:lsp_40()<br />     (initget "T B A")<br />     (setq typ (getkword "\n画线型式 [T顶线,B底线,A上下线] <B>: "))<br />     (if (null typ) (setq typ "B"))<br />     (setq dd (getdist "\n字与线间距 <2>: "))<br />     (if (null dd) (setq dd 2.0))<br />     (setq ss (ssget))<br />     (setq i 0)<br />     (repeat (sslength ss)<br />        (setq ssn (ssname ss i))<br />        (setq ssdata (entget ssn))<br />        (setq key (cdr (assoc 0 ssdata)))<br />        (if (= key "TEXT")<br />           (progn<br />              (command "ucs" "e" ssn)<br />              (setq box (textbox ssdata))<br />              (setq p1 (car box))<br />              (setq p3 (cadr box))<br />              (setq p2 (list (car p3) (cadr p1)))<br />              (setq p4 (list (car p1) (cadr p3)))<br />              (setq ang (angle p1 p4))<br />              (setq ee (entlast))<br />              (cond ((= typ "T") (command "line" (polar p4 ang dd) (polar p3 ang dd) ""))<br />                    ((= typ "B") (command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))<br />                    ((= typ "A") (command "line" (polar p4 ang dd) (polar p3 ang dd) "")<br />                                 (command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))<br />              )   <br />           )   <br />         )<br />         (setq i (1+ i))<br />      )<br />      (command "ucs" "")<br />      (prin1)<br /> )  <br />

ㄘ丶转裑ㄧ灬

文本加双下划线

1. ;;;;;;***************************文本加双下划线
   
2. (defun c:T4 (/     box   ent   ent1  h     nent1 nent2 np1   np2
   
3.        np3   np4   old_lay     p     p1x   p1y   p2x   p2y
   
4.        px     py   r     snap  test
   
5.       )
   
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.4)) 0.0))
    
35. ;;;; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h
    
36. ;;;; 0.3)竖直方向距0.3倍字高。
    
37.   (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.4)) 0.0))
    
38. ;;;; 第一条线段右端点坐标
    
39.   (setq np3 (list (- px (* h 0.2)) (- py (* h 0.56))))
    
40. ;;;; 第二条线段左端点坐标
    
41.   (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0))
    
42. ;;;; 第二条线段右端点坐标
    
43.   (SETVAR "CLAYER" TEST)    ; 文本所在图层设为当前图层
    
44.   (COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "")
    
45. ;;;; 第一条下划线。(/ h
    
46. ;;;; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。
    
47.   (setq nent1 (entlast))
    
48.   (COMMAND "line" np3 np4 "")    ; 第二条下划线
    
49.   (setq nent2 (entlast))
    
50.   (if (/= r 0.0);;;; 如果文本不水平则旋转下划线角度
    
51.     (progn
    
52.       (COMMAND "rotate" nent1 "" p (* 180.0 (/ r pi)))
    
53.       (COMMAND "rotate" nent2 "" p (* 180.0 (/ r pi)))
    
54.     )
    
55.   )
    
56.   (setvar "osmode" snap)
    
57.   (setvar "clayer" old_lay)    ; 恢复当前图层
    
58.   (command ".UNDO" "E")
    
59.   (princ)
    
60. )

;;;;;;***************************文本加双下划线<br /> (defun c:T4 (/     box   ent   ent1  h     nent1 nent2 np1   np2<br />        np3   np4   old_lay     p     p1x   p1y   p2x   p2y<br />        px     py   r     snap  test<br />       )<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 />   (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.4)) 0.0))<br /> ;;;; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h<br /> ;;;; 0.3)竖直方向距0.3倍字高。<br />   (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.4)) 0.0))<br /> ;;;; 第一条线段右端点坐标<br />   (setq np3 (list (- px (* h 0.2)) (- py (* h 0.56))))<br /> ;;;; 第二条线段左端点坐标<br />   (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0))<br /> ;;;; 第二条线段右端点坐标<br />   (SETVAR "CLAYER" TEST)    ; 文本所在图层设为当前图层<br />   (COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "")<br /> ;;;; 第一条下划线。(/ h<br /> ;;;; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。<br />   (setq nent1 (entlast))<br />   (COMMAND "line" np3 np4 "")    ; 第二条下划线<br />   (setq nent2 (entlast))<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 /> )

bai2000

不支持天正的文字

GamIng

bai2000 发表于 2014-11-27 20:03
不支持天正的文字

楼主发的就是天正的，没必要抛开天正折腾自己！

ryujacky

谢谢楼上各位，谢谢!!