[LISP程序]：给文字添加下划线。

haijiangl

自编的小程序，欢迎指教，command：LL

易秋心

gh 下来用用!谢谢!

qiaqiadeng

一直在找呢，现在终于吃现成的了，很好啊，多谢。

wuzz

省事点就用%%u

ak50

也来个下划线的程序
(defun c:xhx(/ ss a n s0 s1 s2)
    (setq ss(ssget '((0 . "text")))
           a(sslength ss)
           n 0
    )
   (while( > a n)
        (setq s0(entget(ssname ss n))
              s1(cdr(assoc 1 s0))
              s2(strcat "%%u" s1))
              (setq s0(subst (cons 1 s2) (assoc 1 s0) s0)
                     n(1+ n)
              )
              (entmod s0)
      
   )
)

kingtony8240

十分感谢,这样省事多了

qiaqiadeng

VBA版的超级加下划线，将原来的下划线删除，因此小心不要选择有用的东西，否则就删除了。
Public Sub ModelZx() '生成文字下划线
Dim Sela As AcadSelectionSet
Dim i As Integer
Dim Num As Integer '
Dim Obj As AcadEntity
Dim Pa As Variant, P1 As Variant
Dim MinPoint As Variant, MaxPoint As Variant
Dim Xiahuaxian(0 To 5) As Double
Dim LL
Dim HH As Integer '字符间隙
Dim SS As Integer '两头伸出长度
Dim Bs As String
Dim Bw As Integer
Dim ang As Double '文字旋转角度
        
HH = 100
SS = 200

HH = 100
SS = 200
Bs = ThisDrawing.Utility.GetString(False, "请输入下划线宽(80):")
If Bs = "" Then
        Bw = 80
    Else
        Bw = Int(Val(Bs))
End If

On Error Resume Next
Num = ThisDrawing.SelectionSets.count
For i = 0 To Num - 1
    Set Sela = ThisDrawing.SelectionSets.Item(i)
    If Sela.Name = "sela" Then
        Sela.Delete
    End If
Next i
Set Sela = ThisDrawing.SelectionSets.Add("sela")
Sela.SelectOnScreen
Newtuceng '建立新图层

For Each Obj In Sela
    If Obj.ObjectName = "AcDbText" Or Obj.ObjectName = "AcDbMText" Then
        If Obj.Rotation = 0 Then
            Obj.GetBoundingBox MinPoint, MaxPoint
            Xiahuaxian(0) = MinPoint(0) - SS
            Xiahuaxian(1) = MinPoint(1) - HH
            Xiahuaxian(3) = MaxPoint(0) + SS
            Xiahuaxian(4) = MinPoint(1) - HH
            Set LL = ThisDrawing.ModelSpace.AddPolyline(Xiahuaxian)
            LL.ConstantWidth = Bw
            LL.Layer = "T图名"
        Else

            ang = Obj.Rotation
            Obj.Rotate Obj.InsertionPoint, -ang
            Obj.GetBoundingBox MinPoint, MaxPoint
            Xiahuaxian(0) = MinPoint(0) - SS
            Xiahuaxian(1) = MinPoint(1) - HH
            Xiahuaxian(3) = MaxPoint(0) + SS
            Xiahuaxian(4) = MinPoint(1) - HH
            Set LL = ThisDrawing.ModelSpace.AddPolyline(Xiahuaxian)
            LL.ConstantWidth = Bw
            LL.Layer = "T图名"
            Obj.Rotate Obj.InsertionPoint, ang
            LL.Rotate Obj.InsertionPoint, ang
        End If
    Else
        Obj.Delete
End If
Next
End Sub

bin_karrie

不能用啊，樓上的。

xyp1964

试试签名栏下“文本编辑套件”之“下划线”的功能

qiaqiadeng

出什么错拉？

ppcat121

支持一下，挺好用

carrot1983

http://www.xdcad.net/forum/showt ... 3080667#post3080667
俺也有。。。。哈哈。。。

HLB_Konan

楼主的程序好  %%u 不好 底线要加粗的

gccghl

怎么已经下不了了？？请楼主重发一个！

Q小Q

%%u只能加一条一划线，有没有加二条的。