沙漠骆驼工具箱源码-1文本相关-文本操作1

woxing1987

工具条：文本操作1，界面和代码如下：
1 界面：


2代码如下：

''''每个click事件的后面注释了当前按钮的名称

Dim filtertype() As Integer '定义选择过滤器类型的dsf组码， 动态数组
Dim filterdata() As Variant '定义过滤器的值，为动态数组
Dim sset1 As AcadSelectionSet

Private Sub CommandButton1_Click() '改字高
        Me.Hide
        On Error Resume Next
        Dim zigao As Double
        zigao = ThisDrawing.Utility.GetReal("请输入字高:")
        'On Error GoTo c1:
        ReDim filtertype(5)
        ReDim filterdata(5)
        filtertype(0) = -4
        filterdata(0) = "<or"
        filtertype(1) = 0
        filterdata(1) = "text"
        filtertype(2) = 0
        filterdata(2) = "mtext"
        filtertype(3) = 0
        filterdata(3) = "dimension"
        filtertype(4) = 0
        filterdata(4) = "insert"
        filtertype(5) = -4
        filterdata(5) = "or>"

        Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
        If Err.Number <> 0 Then
            Err.Clear
            Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
            sset1.Clear
        End If
        ThisDrawing.Utility.prompt ("请框选文本:")
        sset1.SelectOnScreen filtertype, filterdata
        If sset1.count = 0 Then
            ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
            Me.show
            Exit Sub
        End If
        Dim element As Variant
        Dim shuxingneirong As Variant
        Dim aaa As AcadBlock
        Dim i As Integer
        Dim j As Integer
        Dim k As Double
        For k = 0 To sset1.count - 1
            Set element = sset1.Item(k)
            If element.ObjectName = "AcDbBlockReference" Then
                    Set aaa = ThisDrawing.Blocks.Item(element.name)
                    For i = 0 To aaa.count - 1  '改块内字体高度
                        'MsgBox aaa.Item(i).ObjectName
                        'MsgBox aaa.Item(i).name
                        If aaa.Item(i).ObjectName = "AcDbText" Or aaa.Item(i).ObjectName = "AcDbMText" Then
                            'MsgBox aaa.Item(i).height
                            aaa.Item(i).height = zigao
                        End If
                        If sset1.Item(k).HasAttributes Then
                            shuxingneirong = element.GetAttributes
                            For j = LBound(shuxingneirong) To UBound(shuxingneirong)
                                    shuxingneirong(j).height = zigao '改属性块内字体高度
                            Next
                        End If
                    Next
            ElseIf element.ObjectName = "AcDbText" Or element.ObjectName = "AcDbMText" Then  '修改普通文本的字体高度
                    element.height = zigao
            Else   '修改尺寸标注的字体高度
                   element.TextHeight = zigao
            End If
        Next
'c1:
'    If Err.Number <> 0 Then
'        Err.Clear
'        Me.Show
'        Exit Sub
'    End If
    ThisDrawing.Regen acActiveViewport
    sset1.Clear
    sset1.Delete
    Me.show
End Sub


Private Sub CommandButton13_Click() '打散单行文本
    Me.Hide
    On Error Resume Next
    Dim danhangwenben1 As AcadText
    Dim danhangwenben2 As AcadText
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity danhangwenben1, basepnt, "请拾取一个单行文本:"
    If Err Then
        Me.show
        Exit Sub
    End If
    Dim textlen As Single
    Dim textstr As String
    textlen = Len(danhangwenben1.textstring)
    Dim zigao As Double
    zigao = danhangwenben1.height
    Dim qidian(0 To 2) As Double
    qidian(0) = danhangwenben1.InsertionPoint(0)
    qidian(1) = danhangwenben1.InsertionPoint(1)
    For i = 0 To textlen - 1
        qidian(0) = danhangwenben1.InsertionPoint(0) + i * (zigao + 1)
        qidian(1) = danhangwenben1.InsertionPoint(1)
        textstr = Mid(danhangwenben1.textstring, i + 1, 1)
        Set danhangwenben2 = ThisDrawing.ModelSpace.AddText(textstr, qidian, zigao)
        danhangwenben2.StyleName = danhangwenben1.StyleName
    Next
    danhangwenben1.Delete
    Me.show
End Sub

Private Sub CommandButton16_Click() '交换两个文本内容
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要交换内容的两个文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Or sset1.count > 2 Then
        ThisDrawing.Utility.prompt "-----选择失败----请重新拾取两个文本-----" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    strtext = sset1.Item(0).textstring
    sset1.Item(0).textstring = sset1.Item(1).textstring
    sset1.Item(1).textstring = strtext
    sset1.Clear
    Me.show
End Sub

Private Sub CommandButton17_Click() '文字外加矩形框
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要加外边框的文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim currentlayername As String
    Dim waikuanglayer As AcadLayer
    currentlayername = ThisDrawing.ActiveLayer.name
    Set waikuanglayer = ThisDrawing.Layers.Add("waikuang")
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = waikuanglayer
    Dim box1 As Variant
    Dim box2 As Variant
    Dim linelist(0 To 9) As Double
   'Dim kuang As AcadLWPolyline
    Dim element As AcadEntity
    For Each element In sset1
        If element.ObjectName = "AcDbMText" Then
            element.width = 0
        End If
        element.GetBoundingBox box1, box2
        box1(0) = box1(0) - 0.5: box1(1) = box1(1) - 0.5
        box2(0) = box2(0) + 0.5: box2(1) = box2(1) + 0.5
        linelist(0) = box1(0): linelist(1) = box1(1)
        linelist(2) = box2(0): linelist(3) = box1(1)
        linelist(4) = box2(0): linelist(5) = box2(1)
        linelist(6) = box1(0): linelist(7) = box2(1)
        linelist(8) = box1(0): linelist(9) = box1(1)
        ThisDrawing.ModelSpace.AddLightWeightPolyline linelist
    Next
    sset1.Clear
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
    Me.show
End Sub

Private Sub CommandButton18_Click() '文字外加圆形框
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要加外边框的文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim currentlayername As String
    Dim waikuanglayer As AcadLayer
    currentlayername = ThisDrawing.ActiveLayer.name
    Set waikuanglayer = ThisDrawing.Layers.Add("waikuang")
    ThisDrawing.SetVariable "cecolor", "256"
    ThisDrawing.ActiveLayer = waikuanglayer
    Dim box1 As Variant
    Dim box2 As Variant
    Dim zhijing As Double
    Dim zhongxin(0 To 2) As Double
    Dim element As AcadEntity
    For Each element In sset1
        If element.ObjectName = "AcDbMText" Then
            element.width = 0
        End If
        element.GetBoundingBox box1, box2
        zhongxin(0) = (box1(0) + box2(0)) / 2
        zhongxin(1) = (box1(1) + box2(1)) / 2
        zhijing = ((box2(0) - box1(0)) ^ 2 + (box2(1) - box1(1)) ^ 2) ^ 0.5 + 1
         ThisDrawing.ModelSpace.AddCircle zhongxin, zhijing / 2
    Next
    sset1.Clear
    '恢复图层
    ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername)
    Me.show
End Sub



Private Sub CommandButton2_Click() '改多行文字宽度
    Me.Hide
    On Error Resume Next
    Dim kuandu As Double
    kuandu = ThisDrawing.Utility.GetReal("请输入多行文本的宽度(0):")
    ReDim filtertype(0)
    ReDim filterdata(0)
    filtertype(0) = 0
    filterdata(0) = "mtext"

    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选多行文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim element As AcadEntity
    For Each element In sset1
        element.width = kuandu
    Next
    Me.show
End Sub

Private Sub CommandButton20_Click() '选择相同内容的文本
    Me.Hide
    On Error Resume Next
    Dim wenbenobj As AcadEntity
    Dim base As Variant
    Dim textneirong As String
    ThisDrawing.Utility.GetEntity wenbenobj, base, "请选取一个文本:" & vbCrLf
    If Err Then
        ThisDrawing.Utility.prompt "-----选取失败------" & vbCrLf
        Me.show
        Exit Sub
    End If
    textneirong = wenbenobj.textstring
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    'ThisDrawing.Utility.Prompt ("请选择一个文本:")
    sset1.Select acSelectionSetAll, , , filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Exit Sub
    End If

''''----------------第一种方法，用隐藏的方法进行过滤选择-----------------
'    Dim biankuang As biankuangzuobiao
'    biankuang = huoqukuang(sset1)     '获取选择集的最大边框
'    Dim i As Integer
'    Dim j As Integer
'    ReDim yincangobjs(sset1.count - 1) As AcadEntity
'    For i = 0 To sset1.count - 1
'        If sset1.Item(i).textString <> textneirong Then
'            sset1.Item(i).Visible = False  '隐藏对象
'            Set yincangobjs(j) = sset1.Item(i)
'            j = j + 1
'        End If
'    Next
'
'    Dim pp1(0 To 2) As Double
'    Dim pp2(0 To 2) As Double
'    '第二次选择，只选择可见对象
'    pp1(0) = biankuang.x1 '左下角点x
'    pp1(1) = biankuang.y1 '左下角点y
'    pp2(0) = biankuang.x2 '右上角点x
'    pp2(1) = biankuang.y2 '右上角点y
'    sset1.Clear '清空选择集
'    quxiao '调用取消命令
'    sset1.Select acSelectionSetCrossing, pp1, pp2, filtertype, filterdata
'
'    ThisDrawing.SetVariable "nomutt", 1
'    With ThisDrawing
'        .SendCommand "(setq ss1 (ssget ""p""))" '命令行(setq ss1 (ssget "p"))
'        .SendCommand "(sssetfirst nil ss1)" & vbCr
'        .Utility.Prompt "正在选择......" & vbCrLf
'    End With
'    ThisDrawing.SetVariable "NOMUTT", 0
'    ThisDrawing.Utility.Prompt "-------选择成功-------by沙漠骆驼-------" & vbCrLf
'    ThisDrawing.Utility.Prompt "一共选择了  " & sset1.count & "  个对象。" & vbCrLf
'    sset1.Clear
'    sset1.Delete
'    For i = 0 To j - 1 '恢复显示之前隐藏的对象
'        yincangobjs(i).Visible = True
'    Next
'''----------------第一种方法，用隐藏的方法进行过滤选择-----------------

''----------------第二种方法,用添加颜色的方式进行过滤选择---------------------
    ThisDrawing.SetVariable "nomutt", 1
    Dim i As Double
    Dim j As Double
    Dim k As Double
    ReDim shanchu(sset1.count - 1) As AcadEntity
    ReDim shanchucolor(sset1.count - 1) As String
    ReDim baoliu(sset1.count - 1) As AcadEntity
    ReDim baoliucolor(sset1.count - 1) As String
    For i = 0 To sset1.count - 1
        If sset1.Item(i).textstring = textneirong Then
            Set baoliu(k) = sset1.Item(i)
            baoliucolor(k) = sset1.Item(i).color
            sset1.Item(i).color = 222  '假定的颜色值
            k = k + 1
        End If
    Next
    sset1.Clear
    ThisDrawing.Application.ZoomExtents
'
'    '有问题，没有过滤掉不相同的文本，还是选择了所有的文本
'    Dim sset2 As AcadSelectionSet
'    Set sset2 = ThisDrawing.SelectionSets.Add("ss2")
'    If Err.Number <> 0 Then
'        Err.Clear
'        Set sset2 = ThisDrawing.SelectionSets.Item("ss2")
'        sset2.Clear
'    End If
    ReDim filtertype(4)
    ReDim filterdata(4)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    filtertype(4) = 62  '颜色编号，
    filterdata(4) = 222
    ThisDrawing.Utility.prompt ("请框选范围:")
    'sset1.Select acSelectionSetAll, , , filtertype, filterdata
    sset1.SelectOnScreen filtertype, filterdata
    With ThisDrawing
        .SendCommand "(setq ss1 (ssget ""p""))" '命令行(setq ss1 (ssget "p"))
        .SendCommand "(sssetfirst nil ss1)" & vbCr
        '.Utility.Prompt "正在选择......" & vbCrLf
    End With
    ThisDrawing.SetVariable "NOMUTT", 0
    ThisDrawing.Utility.prompt "-------正在选择-------by沙漠骆驼-------" & vbCrLf

    '恢复对象原来的颜色
    For i = 0 To k - 1
        baoliu(i).color = baoliucolor(i)
    Next
    ThisDrawing.Application.ZoomPrevious
    ThisDrawing.Utility.prompt "一共选择了  " & sset1.count & "  个对象。" & vbCrLf
    sset1.Clear
'''----------------第二种方法-------------------------------------
    Me.show
End Sub

Private Sub CommandButton22_Click() '文字归正
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选要归正文本:")
    sset1.SelectOnScreen filtertype, filterdata
    'MsgBox  sset1.count
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim xuanzhuanjiaodu As Double
    'ThisDrawing.Utility.Prompt ("请输入保留的小数位数:") & vbCrLf
    xuanzhuanjiaodu = ThisDrawing.Utility.GetReal("请输入对正角度(0):")
    Dim wenben1 As AcadEntity
    For Each wenben1 In sset1
        wenben1.Rotation = xuanzhuanjiaodu * Atn(1) / 45  'pi=atn(1)/45,tan(45°)=1
    Next
    Me.show
End Sub
'计算角度  格式是弧度
Function angle(ByVal p1 As Variant, ByVal p2 As Variant) As Double
    angle = ThisDrawing.Utility.AngleFromXAxis(p1, p2)
End Function
Private Sub CommandButton23_Click() '文字按线对齐
    Me.Hide
    On Error Resume Next
    'Dim returnobj As AcadLine
    Dim returnobj As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.SetVariable "pickbox", 5
    ThisDrawing.Utility.GetEntity returnobj, basepnt, "请拾取对齐直线(退出):"
    If Err Then
        ThisDrawing.Utility.prompt "-------拾取失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        ThisDrawing.SetVariable "pickbox", 3
        Exit Sub
    End If
    returnobj.Highlight True
    ThisDrawing.SetVariable "pickbox", 3
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选要归正文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim xuanzhunjiaodu As Double
    If returnobj.ObjectName = "AcDbLine" Then
        xuanzhunjiaodu = angle(returnobj.startpoint, returnobj.endpoint)
    Else
        xuanzhunjiaodu = plineangle(returnobj, basepnt)
    End If
    For Each wenben1 In sset1
        wenben1.Rotation = xuanzhunjiaodu
    Next
    returnobj.Highlight False
    Me.show
End Sub
'求两点之间的距离
Function distance(sp As Variant, ep As Variant) As Double
    Dim dx As Double, dy As Double, dz As Double
    dx = sp(0) - ep(0)
    dy = sp(1) - ep(1)
    'dz = sp(2) - ep(2)
    distance = Sqr(dx ^ 2 + dy ^ 2)
End Function
Private Function plineangle(plineobj As AcadObject, pt As Variant) As Double
    Dim p1(0 To 2) As Double, p2(0 To 2) As Double
    Dim count As Integer, i As Integer 'i是多段线的线段索引编号
    Dim d1 As Double, d2 As Double, d3 As Double
    count = UBound(plineobj.Coordinates) \ 2
    For i = 0 To count - 1
        d1 = distance(plineobj.Coordinate(i), pt)
        d2 = distance(pt, plineobj.Coordinate(i + 1))
        d3 = distance(plineobj.Coordinate(i), plineobj.Coordinate(i + 1))
        'MsgBox d1 & Chr(13) & d2 & Chr(13) & d1 + d2 & Chr(13) & d3
        p1(0) = plineobj.Coordinate(i)(0)
        p1(1) = plineobj.Coordinate(i)(1)
        p2(0) = plineobj.Coordinate(i + 1)(0)
        p2(1) = plineobj.Coordinate(i + 1)(1)
        If Abs((d1 + d2 - d3) / d3) < 0.01 Then
           Exit For
        End If
    Next
    '已经确定拾取的点在多段线的哪个位置，i是多段线的线段索引编号
    'MsgBox i
    'MsgBox count
    If i < count Then                       '多段线不是闭合的
        plineangle = angle(p1, p2)
    Else                                   '多段线是闭合的
        p1(0) = plineobj.Coordinate(0)(0)
        p1(1) = plineobj.Coordinate(0)(1)
        plineangle = angle(p1, p2)
    End If
End Function


Private Sub CommandButton24_Click() '文字加前后缀
    Me.Hide
    Dim qianzhui As String
    Dim houzhui As String
    On Error Resume Next
    'ThisDrawing.Utility.Prompt ("请输入保留的小数位数:") & vbCrLf
    qianzhui = ThisDrawing.Utility.GetString(False, "请输入前缀(不输表示空白):")
    If Err Then
        ThisDrawing.Utility.prompt "-------输入错误-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    houzhui = ThisDrawing.Utility.GetString(False, "请输入后缀(不输表示空白):")
    If Err Then
        ThisDrawing.Utility.prompt "-------输入错误-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim zifu As String
    For Each wenben1 In sset1
        zifu = wenben1.textstring
        wenben1.textstring = qianzhui & zifu & houzhui
    Next
    Me.show
End Sub

Private Sub CommandButton25_Click() '文字消除空格
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim zifu As String
    Dim zuihouzifu As String
    Dim changdu As Integer
    Dim i As Integer
    For Each wenben1 In sset1
        zuihouzifu = ""
        zifu = wenben1.textstring
        changdu = Len(zifu)
        For i = 1 To changdu
            If Mid(zifu, i, 1) <> " " Then
                zuihouzifu = zuihouzifu & Mid(zifu, i, 1)
            End If
        Next
        wenben1.textstring = zuihouzifu
    Next
    Me.show
End Sub

Private Sub CommandButton26_Click() '文字消除空格
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim zifu As String
    Dim zuihouzifu As String
    Dim changdu As Integer
    Dim i As Integer
    For Each wenben1 In sset1
        zuihouzifu = ""
        zifu = wenben1.textstring
        changdu = Len(zifu)
        For i = 1 To changdu - 1
            If Mid(zifu, i, 1) <> " " Then
                zuihouzifu = zuihouzifu & Mid(zifu, i, 1) & " "
            Else
                zuihouzifu = zuihouzifu & Mid(zifu, i, 1)
            End If
        Next
        wenben1.textstring = zuihouzifu & Right(zifu, 1)
    Next
    Me.show
End Sub

Private Sub CommandButton27_Click() '删除空文本
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.Select acSelectionSetAll, , , filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim i As Double
    For Each wenben1 In sset1
        If Trim(wenben1.textstring) = "" Then
            wenben1.Delete
            i = i + 1
        End If
    Next
    ThisDrawing.Utility.prompt "-------共删除 " & i & "个空文本-------" & vbCrLf
End Sub

Private Sub CommandButton28_Click() '添加日期文本
    Me.Hide
    On Error Resume Next
    Dim currentosmode As Integer
    currentosmode = ThisDrawing.GetVariable("osmode")
    ThisDrawing.SetVariable "OSMODE", 0
    'ThisDrawing.ObjectSnapMode = False '取消所有对象捕捉
    Dim textobj As AcadText '定义日期文本
    Dim charudian As Variant
    charudian = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    If Err Then
        Err.Clear
        Me.show
        Exit Sub
    End If
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    Dim p1 As Variant
    Dim p2 As Variant
    Dim pz(0 To 2) As Double
    Dim textmiddlepoint(0 To 2) As Double
    Dim plineobj As AcadLWPolyline

    pz(0) = charudian(0)
    pz(1) = charudian(1)
    Dim countnow As Integer  '此处设定一个变量，用于记录当前图形个数，
                             '如果创建不成功，则图形个数不变
    countnow = ThisDrawing.ModelSpace.count
    textobj.Visible = False '避免产生文字框多段线
    ThisDrawing.SendCommand "(command ""-boundary""" & "(list " & pz(0) & " " & pz(1) & ")"""") "
    'ThisDrawing.SendCommand "-boundary" & "(list " & pz(0) & " " & pz(1) & ")" & vbCr
    textobj.Visible = True
    If ThisDrawing.ModelSpace.count = countnow Then '没有表格的话，直接插入
        Set textobj = ThisDrawing.ModelSpace.AddText(Format(Date, "yyyy-mm-dd"), charudian, 3)
        textobj.Alignment = acAlignmentMiddleCenter
        textobj.TextAlignmentPoint = charudian
    Else
        Set plineobj = ThisDrawing.ModelSpace.Item(ThisDrawing.ModelSpace.count - 1)
        plineobj.GetBoundingBox p1, p2
        plineobj.Delete     '删除多段线
        textmiddlepoint(0) = (p1(0) + p2(0)) / 2 '表格中心x点
        textmiddlepoint(1) = (p1(1) + p2(1)) / 2 '表格中心y点
        Set textobj = ThisDrawing.ModelSpace.AddText(Format(Date, "yyyy-mm-dd"), textmiddlepoint, 3)
        textobj.Alignment = acAlignmentMiddleCenter
        textobj.TextAlignmentPoint = textmiddlepoint
    End If
    Me.show
    ThisDrawing.SetVariable "OSMODE", currentosmode
'    MsgBox Format(Time, "h-m-s")
'    MsgBox Date
'    MsgBox Format(Date, "yyyy-mm-dd")
End Sub

Private Sub CommandButton29_Click() '修改文本内容，修改块文本暂时还没有解决
    Me.Hide
    On Error Resume Next
    Dim strtext As String
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    Dim transmatrix As Variant
    Dim contextdata  As Variant
    'ThisDrawing.Utility.GetSubEntity wenben1, basepnt, transmatrix, contextdata, "请选择要修改的文本，包括属性文本:"
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择要修改的文本，包括属性文本:"
    'MsgBox wenben1.ObjectName
    'MsgBox UBound(contextdata)
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" _
       And wenben1.ObjectName <> "AcDbAttributeDefinition" And wenben1.ObjectName <> "AcDbAttribute" _
        And wenben1.ObjectName <> "AcDbBlockReference" Then
        Me.show
        Exit Sub
    End If
    If wenben1.ObjectName = "AcDbAttributeDefinition" Or wenben1.ObjectName = "AcDbAttribute" Then
        strtext = wenben1.TagString
        strtext = InputBox("选择的文本内容为", "修改文本的内容", strtext)
        wenben1.TagString = strtext

    ElseIf wenben1.ObjectName = "AcDbBlockReference" Then
        ' 获得块参照的属性
        Dim varattributes As Variant
        varattributes = wenben1.GetAttributes
        'MsgBox UBound(varattributes)
        If UBound(varattributes) < 0 Then '=-1 为没有包含属性值
            Me.show
            Exit Sub
        End If
        Dim i As Integer
        'Dim shuxingobj As AcadAttributeReference
        For i = 0 To UBound(varattributes)
            'Set shuxingobj = varattributes(i)
            'MsgBox varattributes(i).textString
            If shifouneibu(basepnt, varattributes(i)) Then Exit For
        Next
        strtext = varattributes(i).textstring
        'MsgBox strtext
        'aa=InputBox(promt,[title],[缺省值],[屏幕位置x方向],[屏幕位置y方向]
        strtext = InputBox("选择的文本内容为", "修改文本的内容", strtext)
        varattributes(i).textstring = strtext
    Else
        strtext = wenben1.textstring
        'aa=InputBox(promt,[title],[缺省值],[屏幕位置x方向],[屏幕位置y方向]
        strtext = InputBox("选择的文本内容为", "修改文本的内容", strtext)
        wenben1.textstring = strtext
    End If
    Me.show
End Sub

Private Sub CommandButton3_Click() '合并单行文本
    Me.Hide
    On Error GoTo e1:
    Dim danhangwenben1 As AcadText
    Dim danhangwenben2 As AcadText
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity danhangwenben1, basepnt, "请拾取第一个单行文本:"
    danhangwenben1.Highlight True
    Dim strtext As String
    strtext = danhangwenben1.textstring
r1:
    ThisDrawing.Utility.GetEntity danhangwenben2, basepnt, "请拾取下一个单行文本:"
    strtext = strtext & danhangwenben2.textstring
    danhangwenben1.textstring = strtext
    danhangwenben2.Delete
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        Exit Sub
    Else
        GoTo r1
    End If
End Sub

Private Sub CommandButton30_Click() '大写转小写
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim zifu As String
    For Each wenben1 In sset1
        zifu = wenben1.textstring
        wenben1.textstring = LCase(zifu)
    Next
    sset1.Clear
    sset1.Delete
    Me.show
End Sub

Private Sub CommandButton31_Click() '小写转大写
    Me.Hide
    On Error Resume Next
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请点选或框选文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim wenben1 As AcadEntity
    Dim zifu As String
    For Each wenben1 In sset1
        zifu = wenben1.textstring
        wenben1.textstring = UCase(zifu)
    Next
    sset1.Clear
    sset1.Delete
    Me.show
End Sub

Private Sub CommandButton32_Click() '相同文本格式刷,选择一个文本后，与之内容相同的文本的属性（包括图层 颜色 宽度比例 字高 对齐点）都相同
    Me.Hide
    On Error Resume Next
    Dim wenbenobj As AcadEntity
    Dim base As Variant

    ThisDrawing.Utility.GetEntity wenbenobj, base, "请选取一个文本用于格式化相同内容的其他文本:" & vbCrLf
    If Err Then
        ThisDrawing.Utility.prompt "-----选取失败------" & vbCrLf
        Me.show
        Exit Sub
    End If
    Dim textneirong As String    '文本内容
    Dim textzigao As Double      '文本字高
    Dim texttuceng As String     '文本图层
    Dim textyanse As String      '文本颜色
    Dim textkuandubili As Double  '文本宽度比例系数
    Dim textduiqidian As Integer  '文本对起点 0～14
    Dim textyangshi As String    '文本字体样式
'    Dim textobj As AcadText
'    Dim mtextobj As AcadMText
'    aa = textobj.textString
'    aa = textobj.Height
'    aa = textobj.Layer
'    aa = textobj.color
''''    aa = textobj.scalefactor
''''    aa = textobj.Alignment = acAlignmentAligned
'    aa = textobj.StyleName

'    aa = mtextobj.textString
'    aa = mtextobj.Height
'    aa = mtextobj.Layer
'    aa = mtextobj.color
''''    aa = mtextobj.width
''''    aa = mtextobj.AttachmentPoint = acAttachmentPointBottomCenter
'    aa = mtextobj.StyleName

    textneirong = wenbenobj.textstring
    ReDim filtertype(3)
    ReDim filterdata(3)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    'ThisDrawing.Utility.Prompt ("请选择一个文本:")
    sset1.Select acSelectionSetAll, , , filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Exit Sub
    End If

''----------------用添加颜色的方式进行过滤选择---------------------
    ThisDrawing.SetVariable "nomutt", 1
    Dim i As Double
    Dim j As Double
    Dim k As Double
    ReDim shanchu(sset1.count - 1) As AcadEntity
    ReDim shanchucolor(sset1.count - 1) As String
    ReDim baoliu(sset1.count - 1) As AcadEntity
    ReDim baoliucolor(sset1.count - 1) As String
    For i = 0 To sset1.count - 1
        If sset1.Item(i).textstring = textneirong Then
            Set baoliu(k) = sset1.Item(i)
            baoliucolor(k) = sset1.Item(i).color
            sset1.Item(i).color = 222  '假定的颜色值
            k = k + 1
        End If
    Next
    sset1.Clear
    ThisDrawing.Application.ZoomExtents
'
'    '有问题，没有过滤掉不相同的文本，还是选择了所有的文本
'    Dim sset2 As AcadSelectionSet
'    Set sset2 = ThisDrawing.SelectionSets.Add("ss2")
'    If Err.Number <> 0 Then
'        Err.Clear
'        Set sset2 = ThisDrawing.SelectionSets.Item("ss2")
'        sset2.Clear
'    End If
    ReDim filtertype(4)
    ReDim filterdata(4)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    filtertype(4) = 62  '颜色编号，
    filterdata(4) = 222
    ThisDrawing.Utility.prompt ("请框选范围:")
    'sset1.Select acSelectionSetAll, , , filtertype, filterdata
    sset1.SelectOnScreen filtertype, filterdata
    With ThisDrawing
        .SendCommand "(setq ss1 (ssget ""p""))" '命令行(setq ss1 (ssget "p"))
        .SendCommand "(sssetfirst nil ss1)" & vbCr
        '.Utility.Prompt "正在选择......" & vbCrLf
    End With
    ThisDrawing.SetVariable "NOMUTT", 0
    ThisDrawing.Utility.prompt "-------正在选择-------by沙漠骆驼-------" & vbCrLf

    '恢复对象原来的颜色
    For i = 0 To k - 1
        baoliu(i).color = baoliucolor(i)
    Next
    ThisDrawing.Application.ZoomPrevious
    ThisDrawing.Utility.prompt "一共选择了  " & sset1.count & "  个对象。" & vbCrLf

'''----------------第二种方法-------------------------------------

    Dim geshiduixiang As AcadEntity
    'MsgBox sset1.count
    For Each geshiduixiang In sset1
        geshiduixiang.height = wenbenobj.height
        geshiduixiang.Layer = wenbenobj.Layer
        geshiduixiang.color = wenbenobj.color
        geshiduixiang.StyleName = wenbenobj.StyleName
        If geshiduixiang.ObjectName = "AcDbText" Then
            geshiduixiang.scalefactor = wenbenobj.scalefactor
            'geshiduixiang.Alignment = wenbenobj.Alignment
        Else
            geshiduixiang.width = wenbenobj.width
            geshiduixiang.AttachmentPoint = wenbenobj.AttachmentPoint
        End If
    Next
    sset1.Clear
    Me.show
End Sub

Private Sub CommandButton4_Click() '合并多行文本
    Me.Hide
    On Error GoTo e1:
    Dim duohangwenben1 As AcadMText
    Dim duohangwenben2 As AcadMText
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity duohangwenben1, basepnt, "请选择第一个多行文本:"
    duohangwenben1.Highlight True
    duohangwenben1.width = 0
    Dim strtext As String
    strtext = duohangwenben1.textstring
r1:
    ThisDrawing.Utility.GetEntity duohangwenben2, basepnt, "请拾取下一个多行文本:"
    strtext = strtext & duohangwenben2.textstring
    duohangwenben1.textstring = strtext
    duohangwenben2.Delete
e1:
    If Err.Number <> 0 Then
        Err.Clear
        Me.show
        Exit Sub
    Else
        GoTo r1
    End If
End Sub

Private Sub CommandButton5_Click() '刷文本,只修改内容
    Me.Hide
    On Error Resume Next
    ReDim filtertype(4)
    ReDim filterdata(4)
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = 0
    filterdata(3) = "dimension"
    filtertype(4) = -4
    filterdata(4) = "or>"
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择源文本:"
    If Err Then
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        If wenben1.TextOverride = "" Then
            strtext = str(wenben1.Measuremen)
        Else
            strtext = wenben1.TextOverride
        End If
    Else
        strtext = wenben1.textstring
    End If
    Set sset1 = ThisDrawing.SelectionSets.Add("ss1")
    If Err.Number <> 0 Then
        Err.Clear
        Set sset1 = ThisDrawing.SelectionSets.Item("ss1")
        sset1.Clear
    End If
    ThisDrawing.Utility.prompt ("请框选要更新的文本:")
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    End If
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            wenben1.TextOverride = strtext
        Else
            wenben1.textstring = strtext
        End If
    Next
    sset1.Clear
    sset1.Delete
    Me.show
End Sub

woxing1987

C:\Users\Administrator\Pictures\文本操作1.png

woxing1987

cq_qg 发表于 2022-2-15 09:35
这个看不到界面贴图

woxing1987

foer123 发表于 2022-2-8 15:37
这是什么软件开发的源码

CAD 中的 VBA

烟盒迷唇

这么长代码，界面看不到啊

xj6019

感谢分享，虽然我看不懂，也不会用

woxing1987

xj6019 发表于 2022-2-7 19:14
感谢分享，虽然我看不懂，也不会用

哈哈，

foer123

这是什么软件开发的源码

foer123

woxing1987 发表于 2022-2-8 15:46
CAD 中的 VBA

谢谢没用过

longer1000

感谢，非常实用的工具

894560869

感谢分享，虽然我看不懂，也不会用