文本加下划线程序的完善

szx025 发表于 2016-6-8 09:22:59

这个文本加下划线程序是网上下载的，很好用，但是它只能单个选择文本，高手可以优化一下吗，改为可以多选文本，这样对于有几个文本同时需要加下划线时，可以提高效率;;; =================================================================
;;; 文本加杨红颜色下划线
;;; 作者：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)
)

1993063 发表于 2016-6-8 09:47:08

(defun c:tt (/ ss box ent ent1 h nent1 nent2 np1 np2 np3 np4 old_lay p p1x p1y p2x p2y px py r snap test)
(setvar "cmdecho" 0) ; 关闭命令响应
(command ".UNDO" "BE") ; 设置undo起点
(setq snap (getvar "osmode"))
(setvar "osmode" 0) ; 关闭捕捉
(setq old_lay (getvar "clayer")) ; 保存当前图层
(if (setq ss (ssget '((0 . "*text"))))
(repeat (setq i (sslength ss))
   (setq ent1 (ssname ss (setq i (1- i))))
   (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")
)

szx025 发表于 2016-6-8 10:31:22

1993063 发表于 2016-6-8 09:47 static/image/common/back.gif

非常好用，谢谢

1993063 发表于 2016-6-8 12:31:08

szx025 发表于 2016-6-7 16:31 static/image/common/back.gif
非常好用，谢谢

简单的循环处理,楼上应该自己学会

1993063 发表于 2016-6-8 15:14:26

本帖最后由 1993063 于 2016-6-8 02:50 编辑

另外两种方式:
一种用MAPCAR +LAMBDA 一种FOREACH 这两种是转表再处理,上面是直接选择集处理

chenry676 发表于 2020-8-11 16:41:08

对多行文字无效

376394482 发表于 2020-8-19 16:45:25

谢谢分享！ .

zj20190405 发表于 2023-1-18 17:48:43

(defun c:tt (/ i n pt_bc pt_bl pt_br pt_mc pt_tc pttl pttr roundspace ss1 tbox txtentdata txtentname txtenttype xangle xheight xwidth)
(setq ss1 (ssget '((0 . "*TEXT"))))
(if (null ss1)
(progn
   (princ "\n没有文本实体被选择!")
   (exit)
) ; end progn
) ; end if
(setq n (sslength ss1))
(if (not (= nil n)) ; no select objects
(progn
   (setq i 0)
   (while (< i n)
(setq txtentname (ssname ss1 i))
(setq txtentdata (entget txtentname))
(setq i (+ i 1))
(setq txtenttype (cdr (assoc 0 txtentdata)))
; get entity's name:
; "text" or "mtext"
(if (= txtenttype "TEXT") ; this object is simple line text
   (progn
   (vl-cmdf "ucs" "Object" txtentname)
; 定义用户坐标系到文本的方?
   (setq tbox (textbox (list (car txtentdata)))
; must change to a list
   pt_bl (car tbox) ; left bottom point coords
   pttr (cadr tbox) ; right top point coords
   pttl (list (car pt_bl) (cadr pttr))
   pt_br (list (car pttr) (cadr pt_bl))
   ) ; end setq
   (setq roundspace (* 0.2 (distance pt_bl pttl)))
   (setq pt_bl (polar pt_bl pi (* roundspace 2)))
   (setq pt_bl (polar pt_bl (* pi 1.5) roundspace))
   (setq pt_br (polar pt_br 0.0 (* roundspace 2)))
   (setq pt_br (polar pt_br (* pi 1.5) roundspace)) ;
   (vl-cmdf "pline"
      pt_bl
      "w"
      (* roundspace 0.25)
      ""
      pt_br
      ""
   )
   (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
   (vl-cmdf "pline"
      (polar pt_bl (* pi 1.5) (* roundspace 0.6))
      "w"
      0
      ""
      (polar pt_br (* pi 1.5) (* roundspace 0.6))
      ""
   )
   (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
   (vl-cmdf "ucs" "p")
   ) ; end progn
   (progn
   (vl-cmdf "_.JustifyText" txtentname "" "TL")
; 处理为对对齐模式.
   (setq txtentdata (entget txtentname))
   (setq pttl    (cdr (assoc 10 txtentdata))
   xwidth(cdr (assoc 42 txtentdata))
   xheight (cdr (assoc 43 txtentdata))
   xangle(cdr (assoc 50 txtentdata))
   pt_tc    (polar pttl xangle (* xwidth 0.5))
   pttr    (polar pttl xangle xwidth)
   pt_bl    (polar pttl (- xangle (/ pi 2.0)) xheight)
   pt_bc    (polar pt_bl xangle (* xwidth 0.5))
   pt_br    (polar pt_bl xangle xwidth)
   pt_mc    (polar pt_bl
(angle pt_bl pttr)
(/
   (distance pt_bl
      pttr
   )
   2.0 ; end
) ; end angle
   ) ; end polar
   ) ; end setq
   (setq roundspace (* 0.2 (distance pt_bl pttl)))
   (setq xangle (cdr (assoc 50 txtentdata)))
   (setq pt_bl (polar pt_bl xangle (- roundspace)))
   (setq
      pt_bl (polar pt_bl (+ xangle (/ pi 2.0)) (- roundspace))
   )
   (setq pt_br (polar pt_br xangle roundspace))
   (setq
      pt_br (polar pt_br (+ xangle (/ pi 2.0)) (- roundspace))
   )
   (setq pttl (polar pttl xangle (- roundspace)))
   (setq pttl (polar pttl (+ xangle (/ pi 2.0)) roundspace))
   (setq pttr (polar pttr xangle roundspace))
   (setq pttr (polar pttr (+ xangle (/ pi 2.0)) roundspace)) ;
   (vl-cmdf "pline" pt_bl "w" (* roundspace 0.25) "" pt_br "")
   (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
   (vl-cmdf "pline"
      (polar pt_bl (* pi 1.5) (* roundspace 0.6))
      "w"
      0
      ""
      (polar pt_br (* pi 1.5) (* roundspace 0.6))
      ""
   )
   (vl-cmdf "CHPROP" (entlast) "" "C" "BYBlock" "")
; end command
   ) ; end progn
) ; end if
   ) ; end while
) ; end progn
); end if
(vl-cmdf "ucs" "W")
(princ)
)

页: [1]

明经CAD社区's Archiver

文本加下划线程序的完善