kwok 发表于 2014-12-31 15:00 static/image/common/back.gif
用6楼的改了一下，其实楼主也可以自己改一下的，自己改才是适合自己想要的效果:
不支持mtext,是mtext要先 ...
用了一下，感觉不错，选中很多文字也不回出现乱连问题.
试试这个：;;; ********下划线
(defun c:tt ()
(setq sh (getvar "peditaccept"))
(setvar "peditaccept" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq mclayer (getvar "CLAYER"))
(setvar "CLAYER" "0")
(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)) ;
(command "pline" pt_bl "w" (* roundspace 0.25) "" pt_br "" "")
(command "CHPROP" (entlast) "" "C" "BYBlock" "")
(command "pline" (polar pt_bl (* pi 1.5) (* roundspace 0.6)) "w" 0 "" (polar pt_br (* pi 1.5) (* roundspace 0.6)) "")
(command "CHPROP" (entlast) "" "C" "BYBlock" "")
(setvar "peditaccept" sh)
(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)) ;
(command "pline" pt_bl "w" (* roundspace 0.25) "" pt_br "")
(command "CHPROP" (entlast) "" "C" "BYBlock" "")
(command "pline" (polar pt_bl (* pi 1.5) (* roundspace 0.6)) "w" 0 "" (polar pt_br (* pi 1.5) (* roundspace 0.6)) "")
(command "CHPROP" (entlast) "" "C" "BYBlock" "") ; end command
(setvar "peditaccept" sh)
) ; end progn
) ; end if
) ; end while
) ; end progn
) ; end if
(setvar "CLAYER" mclayer)
(vl-cmdf "ucs" "W" "")
(setvar "osmode" osm)
(princ)
)
成仔 发表于 2015-1-5 08:55 static/image/common/back.gif
试试这个：;;; ********下划线
(defun c:tt ()
(setq sh (getvar "peditaccept"))
感觉不错，可是我只要一条下滑线就行了，你这个好像是生成了2条线，一条粗的和一条细的。
非常感谢22楼 要找的就是加文武线的办法
建议ACAD自带动能，只限纯字母下划线长短自动随字体大小
此简单程序仅供参考
;切换字体下划线
(defun c:tt (/ s e o )
(while (setq e (car (entsel "\n选择文字或按任何键退出 ")))
(setq o (vlax-ename->vla-object e))
(vlax-property-available-p o 'TextString)
(setq s (vla-get-TextString o))
(vla-put-TextString o (if (wcmatch s "*%%u*")(vl-string-subst "" "%%u" s)(strcat "%%u" s))))
(princ)
)
非常感谢22楼,要找的就是这样加线的办法
守仁格竹GM 发表于 2014-12-29 13:51
.
这个怎么做到的？能分享下吗
成仔 发表于 2015-1-5 08:55
试试这个：;;; ********下划线
(defun c:tt ()
(setq sh (getvar "peditaccept"))
66666666666666