沙漠骆驼工具箱源码-1文本相关-文本对齐

woxing1987

工具条：文本对齐，界面和代码如下：
1 界面：


2代码如下：

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


Private Sub CommandButton1_Click() '表格文字中对齐
    On Error Resume Next
    'quxiao '调用取消命令
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"

    Dim sset1 As AcadSelectionSet  '文字选择集
    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 Exit Sub
    Dim textobj As AcadEntity
    Dim p1 As Variant
    Dim p2 As Variant
    Dim pz(0 To 2) As Double
    Dim textmiddlepoint(0 To 2) As Double
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    Dim plineobj As AcadLWPolyline
    Dim boundary1 As Variant
    Dim boundary2 As Variant '文字边框
    Dim move1(0 To 2) As Double '定义单行文本中点
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbText" Then
            Set text1 = textobj
            pz(0) = text1.InsertionPoint(0)
            pz(1) = text1.InsertionPoint(1)
        Else
            Set text2 = textobj
            pz(0) = text2.InsertionPoint(0)
            pz(1) = text2.InsertionPoint(1)
        End If
        Dim countnow As Integer  '此处设定一个变量，用于记录当前图形个数，
                                 '如果创建不成功，则图形个数不变，执行下一个next
        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 GoTo nexti
        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点
        If textobj.ObjectName = "AcDbText" Then
            text1.GetBoundingBox boundary1, boundary2
            move1(0) = (boundary1(0) + boundary2(0)) / 2
            move1(1) = (boundary1(1) + boundary2(1)) / 2
            text1.Move move1, textmiddlepoint
        Else
            text2.AttachmentPoint = 5  '正中对齐
            text2.Move text2.InsertionPoint, textmiddlepoint '移动到矩形中点
        End If
nexti:
    Next
    sset1.Clear
    sset1.Delete
End Sub

Private Sub CommandButton2_Click() '左对齐
    Me.Hide
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
        Me.show
        sset1.Delete
        Exit Sub
    End If
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取左对齐边界:")
    If Err Then
        Me.show
        Exit Sub
    End If
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(0) = pointleft(0) '设置x坐标为固定值
    'Dim move1(0 To 2)  As Double
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 2, 3
                    text2.AttachmentPoint = 1
                Case 4, 5, 6
                    text2.AttachmentPoint = 4
                Case 7, 8, 9
                    text2.AttachmentPoint = 7
            End Select
            p1(1) = text2.InsertionPoint(1) '设置y坐标 insertionpoint 就是attachmentpoint 位置的坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = p1(0): move2(1) = boundary1(1)
            text1.Move boundary1, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
    Me.show
End Sub

Private Sub CommandButton3_Click() '中对齐
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取中对齐边界:")
    If sset1.count = 0 Or Err.Number <> 0 Then Exit Sub
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(0) = pointleft(0) '设置x坐标为固定值
    'Dim move1(0 To 2)  As Double
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 2, 3
                    text2.AttachmentPoint = 2
                Case 4, 5, 6
                    text2.AttachmentPoint = 5
                Case 7, 8, 9
                    text2.AttachmentPoint = 8
            End Select
            p1(1) = text2.InsertionPoint(1) '设置y坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = p1(0) - 0.5 * (boundary2(0) - boundary1(0)): move2(1) = boundary1(1)
            text1.Move boundary1, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
End Sub

Private Sub CommandButton4_Click()  '右对齐
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取右对齐边界:")
    If sset1.count = 0 Or Err.Number <> 0 Then Exit Sub
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(0) = pointleft(0) '设置x坐标为固定值
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 2, 3
                    text2.AttachmentPoint = 3
                Case 4, 5, 6
                    text2.AttachmentPoint = 6
                Case 7, 8, 9
                    text2.AttachmentPoint = 9
            End Select
            p1(1) = text2.InsertionPoint(1) '设置y坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = p1(0) - boundary2(0) + boundary1(0): move2(1) = boundary1(1)
            text1.Move boundary1, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
End Sub

Private Sub CommandButton5_Click() '底端对齐
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取底端对齐边界:")
    If sset1.count = 0 Or Err.Number <> 0 Then Exit Sub
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(1) = pointleft(1) '设置y坐标为固定值
    'Dim move1(0 To 2)  As Double
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 4, 7
                    text2.AttachmentPoint = 7
                Case 2, 5, 8
                    text2.AttachmentPoint = 8
                Case 3, 6, 9
                    text2.AttachmentPoint = 9
            End Select
            p1(0) = text2.InsertionPoint(0) '设置x坐标 insertionpoint 就是attachmentpoint 位置的坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = boundary1(0): move2(1) = p1(1)
            text1.Move boundary1, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
End Sub

Private Sub CommandButton6_Click() '顶端对齐
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取顶端对齐边界:")
    If sset1.count = 0 Or Err.Number <> 0 Then Exit Sub
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(1) = pointleft(1) '设置y坐标为固定值
    'Dim move1(0 To 2)  As Double
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 4, 7
                    text2.AttachmentPoint = 1
                Case 2, 5, 8
                    text2.AttachmentPoint = 2
                Case 3, 6, 9
                    text2.AttachmentPoint = 3
            End Select
            p1(0) = text2.InsertionPoint(0) '设置x坐标 insertionpoint 就是attachmentpoint 位置的坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = boundary2(0): move2(1) = p1(1)
            text1.Move boundary2, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
End Sub

Private Sub CommandButton7_Click() '水平中对齐
    ThisDrawing.SetVariable "cmdecho", 0
    ThisDrawing.SetVariable "HPBOUND", 1
    Dim filtertype(0 To 3) As Integer '定义选择过滤器类型的dsf组码
    Dim filterdata(0 To 3) As Variant '定义过滤器的值
    filtertype(0) = -4
    filterdata(0) = "<or"
    filtertype(1) = 0
    filterdata(1) = "text"
    filtertype(2) = 0
    filterdata(2) = "mtext"
    filtertype(3) = -4
    filterdata(3) = "or>"
    On Error Resume Next
    Dim sset1 As AcadSelectionSet  '文字选择集
    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
    Dim pointleft As Variant
    pointleft = ThisDrawing.Utility.GetPoint(, vbCrLf & "请点取对齐边界:")
    If sset1.count = 0 Or Err.Number <> 0 Then Exit Sub
    Dim textobj As AcadEntity
    Dim p1(0 To 2) As Double
    p1(1) = pointleft(1) '设置y坐标为固定值
    'Dim move1(0 To 2)  As Double
    Dim move2(0 To 2)  As Double
    Dim boundary1 As Variant
    Dim boundary2 As Variant
    Dim text1 As AcadText    '定义单行文本
    Dim text2 As AcadMText  '定义多行文本
    For Each textobj In sset1
        If textobj.ObjectName = "AcDbMText" Then
            Set text2 = textobj
            Select Case text2.AttachmentPoint
                Case 1, 4, 7
                    text2.AttachmentPoint = 4
                Case 2, 5, 8
                    text2.AttachmentPoint = 5
                Case 3, 6, 9
                    text2.AttachmentPoint = 6
            End Select
            p1(0) = text2.InsertionPoint(0) '设置x坐标 insertionpoint 就是attachmentpoint 位置的坐标
            text2.InsertionPoint = p1
        Else
            Set text1 = textobj
            text1.GetBoundingBox boundary1, boundary2
            move2(0) = boundary1(0): move2(1) = p1(1) - 0.5 * (boundary2(1) - boundary1(1))
            text1.Move boundary1, move2
        End If
    Next
    sset1.Clear
    sset1.Delete
End Sub