沙漠骆驼工具箱源码-1文本相关-文本框选运算

woxing1987

工具条：文本框选运算，界面和代码如下：
1 界面：


2代码如下：




Option Explicit '强制要求变量声明
Dim zigao As Double
Dim xiaoshuweishu As Integer
Dim filtertype(3) As Integer '定义选择过滤器类型的dsf组码， 动态数组
Dim filterdata(3) As Variant '定义过滤器的值，为动态数组
Dim hanglieshu As Integer  '定义列数或行数
Dim shujugeshu As Double   '定义数据的个数
Dim jianju As Double
Private Type hanglieshuju   '自定义存储行列数据形式，包含y值，或x值，和文本
    xyzhi As Double
    shuju As Double
End Type
Dim shujuzu1() As hanglieshuju      '定义数组1，用于存放行数据 或列数据
Dim shujuzu2() As hanglieshuju      '定义数组2，用于存放行数据 或列数据
Dim jiaodu As Double   '定义文本旋转角度,为双精度类型
Dim texttype As String '定义文字样式名称
Dim layername As String '定义图层名称
Private Sub CommandButton1_Click()
    xiaoshuweishu = ComboBox2.Text
    'hanglieshu = ComboBox3.Text - 1
    Me.Hide
    On Error Resume Next
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    ReDim jihe(0 To 1) As AcadSelectionSet
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    Dim wenbentext As AcadEntity
    For i = 0 To 1
        Set jihe(i) = ThisDrawing.SelectionSets.Add(i)
        If Err.Number <> 0 Then
            Err.Clear
            Set jihe(i) = ThisDrawing.SelectionSets.Item(i)
            jihe(i).Clear
        End If
        ThisDrawing.Utility.prompt ("-----请框选第" & i + 1 & "行或列数据，选完之后按空格-----")
        jihe(i).SelectOnScreen filtertype, filterdata
        jihe(i).Highlight True
    Next
    If jihe(0).count <> jihe(1).count Then
        MsgBox "所选两组数据个数不同", vbCritical
        Me.show
        Exit Sub
    End If
    jiaodu = jihe(0).Item(0).Rotation  '获取文本角度值
    texttype = jihe(0).Item(0).StyleName '获取文字样式名称
    layername = jihe(0).Item(0).Layer '获取图层名称
    zigao = jihe(0).Item(0).height
    count = jihe(0).count - 1
    ReDim shujuzu1(0 To count)
    ReDim shujuzu2(0 To count)
    Dim zuobiao As Variant
    For j = 0 To count     '第一组数据
        zuobiao = jihe(0).Item(j).InsertionPoint
        If OptionButton1.value Then '按列选择数据，存储y值
            shujuzu1(j).xyzhi = zuobiao(1)
            shujuzu1(j).shuju = jihe(0).Item(j).textstring
        Else
            shujuzu1(j).xyzhi = zuobiao(0) '按行选择数据，存储x值
            shujuzu1(j).shuju = jihe(0).Item(j).textstring
        End If
    Next
    For j = 0 To count     '第二组数据
        zuobiao = jihe(1).Item(j).InsertionPoint
        If OptionButton1.value Then '按列选择数据，存储y值
            shujuzu2(j).xyzhi = zuobiao(1)
            shujuzu2(j).shuju = jihe(1).Item(j).textstring
        Else
            shujuzu2(j).xyzhi = zuobiao(0)  '按行选择数据，存储x值
            shujuzu2(j).shuju = jihe(1).Item(j).textstring
        End If
    Next
    If OptionButton1.value Then    '按y值 从大到小
        Call shuzupaixu_1(shujuzu1())
        Call shuzupaixu_1(shujuzu2())
    Else
        Call shuzupaixu_2(shujuzu1) '按x值 从小到大
        Call shuzupaixu_2(shujuzu2)
    End If
    jianju = Abs(shujuzu1(0).xyzhi - shujuzu1(count).xyzhi) \ count
    Dim ppt1 As Variant
    Dim jieguo As Double

    Dim geshi As String
    geshi = "0." & Right("00000000", xiaoshuweishu)
    If xiaoshuweishu = 0 Then geshi = "0"

    ppt1 = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
    If OptionButton1.value Then '按列插入计算结果
        For i = 0 To count
            If OptionButton3.value Then  '加法运算
                jieguo = shujuzu1(i).shuju + shujuzu2(i).shuju
            ElseIf OptionButton4.value Then '减法运算
                jieguo = shujuzu1(i).shuju - shujuzu2(i).shuju
            ElseIf OptionButton5.value Then '乘法运算
                jieguo = shujuzu1(i).shuju * shujuzu2(i).shuju
            ElseIf OptionButton6.value Then '除法运算
                jieguo = shujuzu1(i).shuju / shujuzu2(i).shuju
            End If
            ppt1(1) = shujuzu1(i).xyzhi
            Set wenbentext = ThisDrawing.ModelSpace.AddText(Format(jieguo, geshi), ppt1, zigao)
            wenbentext.Rotation = jiaodu
            wenbentext.StyleName = texttype ' 文字样式名称
            wenbentext.Layer = layername    '图层名称
            'ppt1(1) = ppt1(1) - jianju
        Next
    Else                     '按行插入计算结果
       For i = 0 To count
            If OptionButton3.value Then  '加法运算
                jieguo = shujuzu1(i).shuju + shujuzu2(i).shuju
            ElseIf OptionButton4.value Then '减法运算
                jieguo = shujuzu1(i).shuju - shujuzu2(i).shuju
            ElseIf OptionButton5.value Then '乘法运算
                jieguo = shujuzu1(i).shuju * shujuzu2(i).shuju
            ElseIf OptionButton6.value Then '除法运算
                jieguo = shujuzu1(i).shuju / shujuzu2(i).shuju
            End If
            ppt1(0) = shujuzu1(i).xyzhi
            Set wenbentext = ThisDrawing.ModelSpace.AddText(Format(jieguo, geshi), ppt1, zigao)
            wenbentext.Rotation = jiaodu
            wenbentext.StyleName = texttype ' 文字样式名称
            wenbentext.Layer = layername    '图层名称
            'ppt1(0) = ppt1(0) + jianju
        Next
    End If
    jihe(0).Highlight False
    jihe(1).Highlight False
    Erase shujuzu1
    Erase shujuzu2
    jihe(0).Clear
    jihe(1).Clear
    jihe(0).Delete
    jihe(1).Delete
    Me.show
End Sub

Private Sub CommandButton2_Click()
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
'    Dim i As Integer
'    For i = 1 To 19  '设置字体高度
'        ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
'    Next
'    For i = 15 To 95 Step 5  '15---95
'        ComboBox1.AddItem i
'    Next
'    For i = 100 To 1000 Step 50 '100---500
'        ComboBox1.AddItem i
'    Next
    ComboBox2.AddItem 0  '设置小数位数
    ComboBox2.AddItem 1
    ComboBox2.AddItem 2
    ComboBox2.AddItem 3
    ComboBox2.AddItem 4
    ComboBox2.AddItem 5
End Sub

Private Sub shuzupaixu_1(ByRef shuzu() As hanglieshuju)   '数组排序，从大到小
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    count = UBound(shuzu)
    Dim ttt As hanglieshuju
    For i = 0 To count - 1
        For j = i + 1 To count
            If shuzu(i).xyzhi < shuzu(j).xyzhi Then
                ttt = shuzu(i)
                shuzu(i) = shuzu(j)
                shuzu(j) = ttt
            End If
        Next
    Next
End Sub

Private Sub shuzupaixu_2(ByRef shuzu() As hanglieshuju)     '数组排序，从小到大
    Dim i As Integer
    Dim j As Integer
    Dim count As Integer
    count = UBound(shuzu)
    Dim ttt As hanglieshuju
    For i = 0 To count - 1
        For j = i + 1 To count
            If shuzu(i).xyzhi > shuzu(j).xyzhi Then
                ttt = shuzu(i)
                shuzu(i) = shuzu(j)
                shuzu(j) = ttt
            End If
        Next
    Next
End Sub

likongshun

感谢楼主分享这么多源码。