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

woxing1987

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


2代码如下：

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






Dim filtertype() As Integer '定义选择过滤器类型的dsf组码， 动态数组
Dim filterdata() As Variant '定义过滤器的值，为动态数组
Dim sset1 As AcadSelectionSet
        
Private Sub CommandButton14_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 zengliang As Double
    zengliang = ThisDrawing.Utility.GetReal("请输入增量值(可以为负):")
    Dim wenben1 As AcadEntity
    Dim zifu As String
    Dim xiaoshuweishu As Integer '记录小数位数
    Dim changdu As Integer
    Dim geshi As String
    For Each wenben1 In sset1
        xiaoshuweishu = 0
        zifu = wenben1.textstring
        changdu = Len(zifu)
        For i = 1 To changdu
            If Left(Right(zifu, i), 1) = "." Then
                xiaoshuweishu = i
                Exit For
            End If
        Next
        zifu = Trim(str(Val(zifu) + zengliang))
        geshi = "0." & Right("000000000000000", xiaoshuweishu - 1)
        If xiaoshuweishu = 0 Then geshi = "0"
        wenben1.textstring = Format(zifu, geshi)
    Next
    Me.show
End Sub


Private Sub CommandButton15_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 zengliang As Double
    zengliang = 1
    zengliang = ThisDrawing.Utility.GetReal("请输入要乘的数(可以为负):")
    Dim wenben1 As AcadEntity
    Dim zifu As String
    Dim xiaoshuweishu As Integer '记录小数位数
    Dim changdu As Integer
    Dim geshi As String
    For Each wenben1 In sset1
        wenben1.textstring = zifu
    Next
    Me.show
End Sub


Private Sub CommandButton21_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 i As Integer
    Dim zifu As String
    For Each wenben1 In sset1
        zifu = wenben1.textstring
        wenben1.textstring = Val(zifu)
    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 CommandButton22_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>"
    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 zuida As Double
    Dim zuixiao As Double
    Dim wenben1 As AcadEntity
    Dim zigao As Double
    zuida = Val(sset1(0).textstring)
    zuixiao = zuida
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            'qiuhe = qiuhe + wenben1.Measurement '尺寸标注文本
            If wenben1.Measurement > zuida Then zuida = wenben1.Measurement
            If wenben1.Measurement < zuixiao Then zuixiao = wenben1.Measurement
            zigao = wenben1.TextHeight
        Else
            If Val(wenben1.textstring) > zuida Then zuida = Val(wenben1.textstring)
            If Val(wenben1.textstring) < zuixiao Then zuixiao = Val(wenben1.textstring)
            zigao = wenben1.height
        End If
    Next
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    Dim ppt1 As Variant
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    'ThisDrawing.ModelSpace.AddText "最大值：" & Format(Trim(str(zuida)), "0.000") & _
      '                        "    最小值：" & Format(Trim(str(zuixiao)), "0.000"), ppt1, zigao
    ThisDrawing.ModelSpace.AddText "最大值：" & Format(zuida, "0.########") & _
                              "  最小值：" & Format(zuixiao, "0.########"), ppt1, zigao
    sset1.Clear
    Me.show
End Sub


Private Sub CommandButton23_Click() '文字求差
    Me.Hide
    On Error Resume Next
    Dim wenben1 As AcadEntity
    Dim wenben2 As AcadEntity
    Dim basepnt As Variant
    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>"
    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 "请选择数字文本A(可以是标注）:" & vbCrLf
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    Else
        Set wenben1 = sset1.Item(0)
    End If
    sset1.Clear
    ThisDrawing.Utility.prompt "请选择数字文本B(可以是标注）:" & vbCrLf
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    Else
        Set wenben2 = sset1.Item(0)
    End If
    Dim shu1 As Double
    Dim shu2 As Double
    Dim chazhi As Double
    Dim zigao As Double
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            shu1 = wenben1.Measurement
            zigao = wenben1.TextHeight
    Else
            shu1 = Val(wenben1.textstring)
            zigao = wenben1.height
    End If
    If wenben2.ObjectName <> "AcDbText" And wenben2.ObjectName <> "AcDbMText" Then
            shu2 = wenben2.Measurement
            zigao = wenben2.TextHeight
    Else
            shu2 = Val(wenben2.textstring)
            zigao = wenben2.height
    End If
    chazhi = shu1 - shu2
    Dim ppt1 As Variant
   
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiuhetext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(chazhi)), "0.000"), ppt1, zigao)
    sset1.Clear
    Me.show
End Sub


Private Sub CommandButton24_Click() '文字求商
    Me.Hide
    On Error Resume Next
    Dim wenben1 As AcadEntity
    Dim wenben2 As AcadEntity
    Dim basepnt As Variant
   
    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>"
    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 "请选择数字文本A(可以使标注）:" & vbCrLf
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    Else
        Set wenben1 = sset1.Item(0)
    End If
    sset1.Clear
    ThisDrawing.Utility.prompt "请选择数字文本B(可以使标注）:" & vbCrLf
    sset1.SelectOnScreen filtertype, filterdata
    If sset1.count = 0 Then
        ThisDrawing.Utility.prompt "-------选择失败-------by沙漠骆驼-------" & vbCrLf
        Me.show
        Exit Sub
    Else
        Set wenben2 = sset1.Item(0)
    End If
    Dim shu1 As Double
    Dim shu2 As Double
    Dim shangzhi As Double
    Dim zigao As Double
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            shu1 = wenben1.Measurement
            zigao = wenben1.TextHeight
    Else
            shu1 = Val(wenben1.textstring)
            zigao = wenben1.height
    End If
    If wenben2.ObjectName <> "AcDbText" And wenben2.ObjectName <> "AcDbMText" Then
            shu2 = wenben2.Measurement
            zigao = wenben2.TextHeight
    Else
            shu2 = Val(wenben2.textstring)
            zigao = wenben2.height
    End If
    If shu2 = 0 Then
        ThisDrawing.Utility.prompt "-------除数不能为 0 -------" & vbCrLf
        MsgBox "除数不能为 0", vbCritical
        Me.show
        Exit Sub
    End If
    shangzhi = shu1 / shu2
    Dim ppt1 As Variant
   
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiuhetext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(shangzhi)), "0.000"), ppt1, zigao)
    sset1.Clear
    Me.show
End Sub


Private Sub CommandButton25_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>"
    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 qiuhe As Double
    Dim pingjunzhi As Double
    Dim wenben1 As AcadEntity
    Dim zigao As Double
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            qiuhe = qiuhe + wenben1.Measurement
            zigao = wenben1.TextHeight
        Else
            qiuhe = qiuhe + Val(wenben1.textstring)
            zigao = wenben1.height
        End If
    Next
    pingjunzhi = qiuhe / sset1.count
    Dim qiuhetext As AcadText
    Dim ppt1 As Variant
   
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiuhetext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(pingjunzhi)), "0.00"), ppt1, zigao)
    sset1.Clear
    Me.show
End Sub


Private Sub CommandButton26_Click() '纯数字递增
    Me.Hide
    On Error GoTo eee1
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择纯数字文本(可以是小数):"
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    strtext = wenben1.textstring
    Dim i As Integer
    For i = 1 To Len(strtext)
        If Left(Right(strtext, i), 1) = "." Then Exit For
    Next
    Dim xiaoshuoweishu As Integer
    If i < Len(strtext) Then
        xiaoshuoweishu = i
    Else
        xiaoshuoweishu = 0
    End If
    'MsgBox xiaoshuoweishu
    Dim geshi As String
    geshi = "0" & Left(".00000", xiaoshuoweishu) 'xiaoshuweishu 实际上多1位
    Dim zengliang As Double
    zengliang = ThisDrawing.Utility.GetReal("请输入增量值:")
    Dim shuliang As Integer
    shuliang = ThisDrawing.Utility.GetInteger("请输入复制个数(大于0):")
    Dim ppt1 As Variant
    Dim ppt2 As Variant
    Dim basepnt1 As Variant
    Dim basepnt2(0 To 2) As Double
    Dim ddx As Double, ddy As Double
    basepnt1 = wenben1.InsertionPoint
    Dim copyobj As AcadEntity
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取第一点:")
    ppt2 = ThisDrawing.Utility.GetPoint(ppt1, "请拾取第二点:")
    ddx = ppt2(0) - ppt1(0)
    ddy = ppt2(1) - ppt1(1)
    For i = 1 To shuliang
        strtext = strtext + zengliang
        Set copyobj = wenben1.Copy()
        copyobj.textstring = Format(strtext, geshi)
        basepnt2(0) = basepnt1(0) + ddx * i
        basepnt2(1) = basepnt1(1) + ddy * i
        copyobj.Move basepnt1, basepnt2
    Next
    Me.show
eee1:
    Err.Clear
    Me.show
End Sub




Private Sub CommandButton27_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 xiaoshuweishu As Integer
    xiaoshuweishu = 2
    xiaoshuweishu = Abs(ThisDrawing.Utility.GetInteger("请输入小数位数(默认2位):"))
    Dim wenben1 As AcadEntity
    Dim zifu As Double
    Dim geshi As String
    geshi = "0." & Right("00000000", xiaoshuweishu)
    If xiaoshuweishu = 0 Then geshi = "0"
    For Each wenben1 In sset1
        zifu = Val(wenben1.textstring)
        If wenben1.textstring = zifu Then
            'MsgBox "相同"
            wenben1.textstring = Format(zifu, geshi)
        End If
    Next
    Me.show
End Sub


Private Sub CommandButton6_Click() '递增复制
    Me.Hide
    On Error GoTo e1:
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择文本(末尾是数字):"
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        Me.show
        Exit Sub
    End If
    'MsgBox wenben1.ObjectName
    Dim strtext As String
    strtext = Right(wenben1.textstring, 1)
    If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then
        Dim i As Integer
        Dim j As Integer
        For i = 2 To Len(wenben1.textstring)
            strtext = Left(Right(wenben1.textstring, i), 1)
            If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then j = j + 1
            If i > j + 1 Then Exit For
        Next
        j = j + 1
        Dim zengliang As Integer
        Dim chushizhi As Double
        zengliang = ThisDrawing.Utility.GetInteger("请输入增量值:")
    End If
    If j = 0 Then
        Me.show
        Exit Sub
    End If
r1:
    chushizhi = chushizhi + zengliang
    strtext = Left(wenben1.textstring, Len(wenben1.textstring) - j) & _
            Val(Right(wenben1.textstring, j)) + chushizhi
    Dim basepnt1 As Variant
    basepnt1 = ThisDrawing.Utility.GetPoint(, "指定插入点:")
    Dim copyobj As AcadEntity
    Set copyobj = wenben1.Copy()
    copyobj.textstring = strtext
    copyobj.Move wenben1.InsertionPoint, basepnt1
   
    If copyobj.ObjectName = "AcDbText" Then
        copyobj.Alignment = acAlignmentMiddleCenter
        copyobj.TextAlignmentPoint = basepnt1
    Else
        copyobj.AttachmentPoint = acAttachmentPointMiddleCenter
        copyobj.InsertionPoint = basepnt1
    End If
e1:
    If Err.Number <> 0 Then
        'MsgBox Err.Description
        Err.Clear
        Me.show
        Exit Sub
    Else
        GoTo r1
    End If
End Sub




Private Sub CommandButton7_Click() '超级递增(数在尾)
    Me.Hide
    On Error GoTo eee1
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择文本(末尾是数字):"
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    strtext = Right(wenben1.textstring, 1)
    If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then
        Dim i As Integer
        Dim j As Integer
        For i = 2 To Len(wenben1.textstring)
            strtext = Left(Right(wenben1.textstring, i), 1)
            If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then j = j + 1
            If i > j + 1 Then Exit For
        Next
        j = j + 1
        Dim zengliang As Double
        zengliang = ThisDrawing.Utility.GetReal("请输入增量值:")
        Dim shuliang As Integer
        shuliang = ThisDrawing.Utility.GetInteger("请输入复制个数(大于0):")
        Dim ppt1 As Variant
        Dim ppt2 As Variant
        Dim basepnt1 As Variant
        Dim basepnt2(0 To 2) As Double
        Dim ddx As Double, ddy As Double
        'Dim juli As Double
        basepnt1 = wenben1.InsertionPoint
        Dim copyobj As AcadEntity
        ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取第一点:")
        ppt2 = ThisDrawing.Utility.GetPoint(ppt1, "请拾取第二点:")
        ddx = ppt2(0) - ppt1(0)
        ddy = ppt2(1) - ppt1(1)
        'juli = ((ppt2(0) - ppt1(0)) ^ 2 + (ppt2(1) - ppt1(1)) ^ 2) ^ 0.5 '* (ppt2(0) - ppt1(0)) / Abs(ppt2(0) - ppt1(0))
        For i = 1 To shuliang
            strtext = Left(wenben1.textstring, Len(wenben1.textstring) - j) & _
                    Val(Right(wenben1.textstring, j)) + zengliang * i
            Set copyobj = wenben1.Copy()
            copyobj.textstring = strtext
            basepnt2(0) = basepnt1(0) + ddx * i
            basepnt2(1) = basepnt1(1) + ddy * i
            copyobj.Move basepnt1, basepnt2
        Next
        Me.show
    End If
eee1:
    Err.Clear
    Me.show
End Sub
Private Sub CommandButton19_Click() '超级递增(数在头)
    Me.Hide
    On Error GoTo eee1
    Dim wenben1 As AcadEntity
    Dim basepnt As Variant
    ThisDrawing.Utility.GetEntity wenben1, basepnt, "请选择文本(文字开头是数字):"
    If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
        Me.show
        Exit Sub
    End If
    Dim strtext As String
    strtext = Left(wenben1.textstring, 1)
    If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then
        Dim i As Integer
        Dim j As Integer
        For i = 2 To Len(wenben1.textstring)
            strtext = Right(Left(wenben1.textstring, i), 1)
            If Val(strtext) > 0 And Val(strtext) <= 9 Or strtext = "0" Then j = j + 1
            If i > j + 1 Then Exit For
        Next
        j = j + 1
        Dim zengliang As Double
        zengliang = ThisDrawing.Utility.GetReal("请输入增量值:")
        Dim shuliang As Integer
        shuliang = ThisDrawing.Utility.GetInteger("请输入复制个数(大于0):")
        'Dim juli As Double
        Dim ppt1 As Variant
        Dim ppt2 As Variant
        Dim basepnt1 As Variant
        Dim basepnt2(0 To 2) As Double
        Dim ddx As Double, ddy As Double
        basepnt1 = wenben1.InsertionPoint
        Dim copyobj As AcadEntity
        ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取第一点:")
        ppt2 = ThisDrawing.Utility.GetPoint(ppt1, "请拾取第二点:")
        ddx = ppt2(0) - ppt1(0)
        ddy = ppt2(1) - ppt1(1)
        'juli = ((ppt2(0) - ppt1(0)) ^ 2 + (ppt2(1) - ppt1(1)) ^ 2) ^ 0.5 '* (ppt2(0) - ppt1(0)) / Abs(ppt2(0) - ppt1(0))
        For i = 1 To shuliang
            strtext = Val(Left(wenben1.textstring, j)) + zengliang * i & _
                      Right(wenben1.textstring, Len(wenben1.textstring) - j)


            Set copyobj = wenben1.Copy()
            copyobj.textstring = strtext
            basepnt2(0) = basepnt1(0) + ddx * i
            basepnt2(1) = basepnt1(1) + ddy * i
            copyobj.Move basepnt1, basepnt2
        Next
        Me.show
    End If
eee1:
    Err.Clear
    Me.show
End Sub
Private Sub CommandButton8_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>"
    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 qiuhe As Double
    Dim wenben1 As AcadEntity
    Dim zigao As Double
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            qiuhe = qiuhe + wenben1.Measurement     '是标注文本
            zigao = wenben1.TextHeight
        Else
            qiuhe = qiuhe + Val(wenben1.textstring)  '单行或是多行文本         sset1.Item(0).textstring
            zigao = wenben1.height
        End If
    Next
    Dim qiuhetext As AcadText
    Dim ppt1 As Variant
   
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
   
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiuhetext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(qiuhe)), "0.000"), ppt1, zigao)
    sset1.Clear
    Me.show
End Sub




Private Sub CommandButton9_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>"
    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 qiuji As Double
    Dim wenben1 As AcadEntity
    qiuji = 1
    Dim zigao As Double
    For Each wenben1 In sset1
        If wenben1.ObjectName <> "AcDbText" And wenben1.ObjectName <> "AcDbMText" Then
            qiuji = qiuji * wenben1.Measurement
            zigao = wenben1.TextHeight
        Else
            qiuji = qiuji * Val(wenben1.textstring)
            zigao = wenben1.height
        End If
    Next
    Dim qiujitext As AcadText
    Dim ppt1 As Variant
    newtextstyle2    '调用新建字体样式程序
    ThisDrawing.SetVariable "textstyle", "wh_lkx"
    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    Set qiujitext = ThisDrawing.ModelSpace.AddText(Format(Trim(str(qiuji)), "0.000"), ppt1, zigao)
    sset1.Clear
    Me.show
End Sub


Private Sub CommandButton10_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 xiaoshuweishu As Integer
    'ThisDrawing.Utility.Prompt ("请输入保留的小数位数:") & vbCrLf
    xiaoshuweishu = ThisDrawing.Utility.GetInteger("请输入保留的小数位数:")
    Dim wenben1 As AcadEntity
    Dim geshi As String
    geshi = "0+000." & Right("000000000000000", xiaoshuweishu)
    If xiaoshuweishu = 0 Then geshi = "0+000"
    For Each wenben1 In sset1
        wenben1.textstring = Format(wenben1.textstring, geshi)
    Next
    Me.show
End Sub






Private Sub CommandButton11_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 zengliang As Double
    zengliang = ThisDrawing.Utility.GetReal("请输入桩号增量值(可以为负):")
    Dim wenben1 As AcadEntity
    Dim i As Integer
    Dim zifu As String
    Dim xiaoshuweishu As Integer '记录小数位数
    Dim changdu As Integer
    Dim geshi As String
    For Each wenben1 In sset1
        xiaoshuweishu = 0
        zifu = wenben1.textstring
        changdu = Len(zifu)
        For i = 1 To changdu
            If Left(Right(zifu, i), 1) = "." Then xiaoshuweishu = i
            If Left(Right(zifu, i), 1) = "+" Then Exit For
        Next
        zifu = Left(wenben1.textstring, Len(wenben1.textstring) - i) & Right(wenben1.textstring, i - 1)
        wenben1.textstring = str(Val(zifu) + zengliang)
        geshi = "0+000." & Right("000000000000000", xiaoshuweishu - 1)
        If xiaoshuweishu = 0 Then geshi = "0+000"
        wenben1.textstring = Format(wenben1.textstring, geshi)
    Next
    Me.show
End Sub






Private Sub CommandButton12_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 i As Integer
    Dim zifu As String
    Dim changdu As Integer
    For Each wenben1 In sset1
        xiaoshuweishu = 0
        zifu = wenben1.textstring
        changdu = Len(zifu)
        For i = 1 To changdu
            If Left(Right(zifu, i), 1) = "+" Then Exit For
        Next
        wenben1.textstring = Val(Left(wenben1.textstring, Len(wenben1.textstring) - i) & Right(wenben1.textstring, i - 1))
    Next
    Me.show
End Sub

yuan4399

怎么用呢 ？？？？？？？？？？

chixun99

刚注意，这是VBA的源码，收藏一下。