这个文本加下划线程序是网上下载的,很好用,但是它只能单个选择文本,高手可以优化一下吗,改为可以多选文本,这样对于有几个文本同时需要加下划线时,可以提高效率- ;;; =================================================================
- ;;; 文本加杨红颜色下划线
- ;;; 作者:langjs 命令:WTH 日期2011年1月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)
- (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)
- )
- (setq p (cdr (assoc 10 ent)) ; 文本基点坐标
- h (cdr (assoc 40 ent)) ; 文本高度
- r (cdr (assoc 50 ent)) ; 文本旋转角度
- TEST (cdr (assoc 8 ent)) ; 文本所在图层
- )
- (setq box (textbox ent)) ; 文本框坐标
- (setq p1x (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.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度,(* h
- ; 0.3)竖直方向距0.3倍字高。
- (setq np2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
- (setq np3 (list (- px (* h 0.2)) (- py (* h 0.46)))) ; 第二条线段左端点坐标
- (setq np4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.46)) 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))
- (COMMAND "CHPROP" nent1 "" "C" "1" ""); 第一条下划线更改为洋红颜色
- (COMMAND "CHPROP" nent2 "" "C" "1" ""); 第二条下划线更改为洋红颜色
- (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)
- )
|