文字加下划线！ 求专家

tyrasv

kwok 发表于 2014-12-31 15:00
用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)
)

tyrasv

成仔 发表于 2015-1-5 08:55
试试这个：;;; ********下划线
(defun c:tt ()
  (setq sh (getvar "peditaccept"))

感觉不错，可是我只要一条下滑线就行了，你这个好像是生成了2条线，一条粗的和一条细的。

snight523

非常感谢22楼   要找的就是加文武线的办法

lisperado

建议ACAD自带动能，只限纯字母下划线长短自动随字体大小

此简单程序仅供参考

1. ;切换字体下划线
   
2. (defun c:tt (/ s e o )
   
3.   (while (setq e (car (entsel "\n选择文字或按任何键退出 ")))
   
4.   (setq o (vlax-ename->vla-object e))
   
5.   (vlax-property-available-p o 'TextString)
   
6.   (setq s (vla-get-TextString o))
   
7.   (vla-put-TextString o (if (wcmatch s "*%%u*")(vl-string-subst "" "%%u" s)(strcat "%%u" s))))
   
8.   (princ)
   
9.   )

;切换字体下划线<br /> (defun c:tt (/ s e o ) <br />   (while (setq e (car (entsel "\n选择文字或按任何键退出 ")))<br />   (setq o (vlax-ename->vla-object e))<br />   (vlax-property-available-p o 'TextString)<br />   (setq s (vla-get-TextString o))<br />   (vla-put-TextString o (if (wcmatch s "*%%u*")(vl-string-subst "" "%%u" s)(strcat "%%u" s))))<br />   (princ)<br />   )

enn09

非常感谢22楼,要找的就是这样加线的办法

sandyvs

守仁格竹GM 发表于 2014-12-29 13:51
.

这个怎么做到的？能分享下吗

ferious

成仔 发表于 2015-1-5 08:55
试试这个：;;; ********下划线
(defun c:tt ()
  (setq sh (getvar "peditaccept"))

66666666666666