langjs 发表于 2011-1-7 15:09:58

回复 hdlyt11 的帖子

;;; =================================================================
;;; 文本加杨红颜色下划线
;;; 作者：langjs   　　　　命令：TT 　　　　　日期2011年1月6日
;;; =================================================================
(defun c:TT (/ 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.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))
(COMMAND "CHPROP" nent1 "" "C" "6" ""); 第一条下划线更改为洋红颜色
(COMMAND "CHPROP" nent2 "" "C" "6" ""); 第二条下划线更改为洋红颜色
(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)
)

hdlyt11 发表于 2011-1-10 09:32:41

非常完美，最重要的是楼主把每句源码的用途写出来了，这样对新手学习是非常有用的，非常的感谢和钦佩。

sy100 发表于 2011-1-11 16:13:54

谢谢楼主，送上新年祝福！

blyl 发表于 2011-2-11 10:56:39

谢谢楼主

blyl 发表于 2011-2-11 11:11:01

很好用

crazylsp 发表于 2011-2-28 19:12:30

很好用,讲解非常详细,谢谢了

zwf100 发表于 2011-5-27 21:19:30

终于找到你了，最近正要它

dongbeiren 发表于 2011-8-30 12:17:55

多谢无私奉献 ！！！

yjr111 发表于 2011-9-22 00:12:29

用处很大！与贱人工具箱的图名线一模一样了，又掏到一个好源码！

doro 发表于 2011-9-22 09:24:31

不错不错 稍微改一下就画一条直线
页: 1 [2] 3 4 5 6
查看完整版本: [原创]文本加下划线程序