求为文字添加标题线的lisp程序
文字下面两条线，一条宽的一条细的.谢谢!!
自己搜索 论坛有！！！ 找了半天没找到才发帖问的，不知道这个东西应该怎么称呼? 是不是我叫的不对，不是标题线? 我贴一个收集的简单的，是单线，自己改为双线就行。(defun c:lsp_40()
(initget "T B A")
(setq typ (getkword "\n画线型式 <B>: "))
(if (null typ) (setq typ "B"))
(setq dd (getdist "\n字与线间距 <2>: "))
(if (null dd) (setq dd 2.0))
(setq ss (ssget))
(setq i 0)
(repeat (sslength ss)
(setq ssn (ssname ss i))
(setq ssdata (entget ssn))
(setq key (cdr (assoc 0 ssdata)))
(if (= key "TEXT")
(progn
(command "ucs" "e" ssn)
(setq box (textbox ssdata))
(setq p1 (car box))
(setq p3 (cadr box))
(setq p2 (list (car p3) (cadr p1)))
(setq p4 (list (car p1) (cadr p3)))
(setq ang (angle p1 p4))
(setq ee (entlast))
(cond ((= typ "T") (command "line" (polar p4 ang dd) (polar p3 ang dd) ""))
((= typ "B") (command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))
((= typ "A") (command "line" (polar p4 ang dd) (polar p3 ang dd) "")
(command "line" (polar p1 (- ang) dd) (polar p2 (- ang) dd) ""))
)
)
)
(setq i (1+ i))
)
(command "ucs" "")
(prin1)
)
文本加双下划线
;;;;;;***************************文本加双下划线
(defun c:T4 (/ box ent ent1h nent1 nent2 np1 np2
np3 np4 old_lay p p1x p1y p2x p2y
px py r snaptest
)
(setq ent1 (car (entsel "\n选择文本：")))
(setvar "cmdecho" 0);;;; 关闭命令响应
(command ".UNDO" "BE") ; 设置undo起点
(setq snap (getvar "osmode"))
(setvar "osmode" 0);;;; 关闭捕捉
(setq old_lay (getvar "clayer")); 保存当前图层
(setq ent (entget ent1))
(if (= "MTEXT" (cdr (assoc 0 ent))); 如选多行文本，则转化为单行文本
(progn
(command ".EXPLODE" ent1)
(setq ent1 (entlast))
(setq ent (entget ent1))
)
(princ)
)
(setqp (cdr (assoc 10 ent)); 文本基点坐标
h (cdr (assoc 40 ent)); 文本高度
r (cdr (assoc 50 ent)); 文本旋转角度
TEST (cdr (assoc 8 ent)); 文本所在图层
)
(setq box (textbox ent)) ; 文本框坐标
(setqp1x (car (car box)) ; 文本左下角X坐标
p1y (car (cdr (car box)))
p2x (car (car (cdr box))); 文本右上角X坐标
p2y (car (cdr (car (cdr box))))
px(car p)
py(car (cdr p))
);;;; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
(setq np1 (list (- px (* h 0.2)) (- py (* h 0.4)) 0.0))
;;;; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h
;;;; 0.3)竖直方向距0.3倍字高。
(setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.4)) 0.0))
;;;; 第一条线段右端点坐标
(setq np3 (list (- px (* h 0.2)) (- py (* h 0.56))))
;;;; 第二条线段左端点坐标
(setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0))
;;;; 第二条线段右端点坐标
(SETVAR "CLAYER" TEST) ; 文本所在图层设为当前图层
(COMMAND "pline" np1 "w" (/ h 10) (/ h 10) np2 "")
;;;; 第一条下划线。(/ h
;;;; 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。
(setq nent1 (entlast))
(COMMAND "line" np3 np4 "") ; 第二条下划线
(setq nent2 (entlast))
(if (/= r 0.0);;;; 如果文本不水平则旋转下划线角度
(progn
(COMMAND "rotate" nent1 "" p (* 180.0 (/ r pi)))
(COMMAND "rotate" nent2 "" p (* 180.0 (/ r pi)))
)
)
(setvar "osmode" snap)
(setvar "clayer" old_lay) ; 恢复当前图层
(command ".UNDO" "E")
(princ)
)
不支持天正的文字 bai2000 发表于 2014-11-27 20:03 static/image/common/back.gif
不支持天正的文字
楼主发的就是天正的，没必要抛开天正折腾自己！ 谢谢楼上各位，谢谢!!
页:
[1]