单行文字对齐平均行距

         我最恨改图了，还不如画新的图纸。特别在调整建筑说明等文字的时候，不是乱码就是变形的乱七八糟，手东调整是很麻烦的。你可以试试下面的：

'文字排版
'       1 文字左对齐
'       2 文字左对齐 且行距相等
'       3 文字行距相等
Function TextAlign(S As Integer)
    Dim RowHeight As Double              '文字间距
    Dim TextFirstPoint(0 To 2) As Double '最上面一行文字的基点坐标
    Dim TextNextPoint(0 To 2) As Double  '文字行距调整后新的基点坐标
    Dim ssText As AcadSelectionSet    '选择集
    Dim acText As AcadText            '选择集中的文本
    Dim DimTxt As Double              '默认文字行距(我自定义为标注文本高度的3倍)
    Dim Y() As Double                 '为了防止选择的文字顺序乱,根据文字插入点的Y坐标进行排序
    Dim j As Integer, N As Integer, Temp As Double    '排序用的临时变量和计数变量
    Dim Index() As Integer            '排序后的Text在原选择集中的序号
   
    On Error Resume Next
    If S <> 1 Then '不需要调整行距则跳过此步骤
        DimTxt = 3 * Val(ThisDrawing.GetVariable("DIMTXT"))
        '获得偏移所有文字对象的间距（从第一个被选择的文字对象开始）
        RowHeight = ThisDrawing.Utility.GetDistance(, "请输入文字的行距(" & DimTxt & "):")
        '错误检查
        If Err.Number = -2147352567 Then
            Exit Function              '用户按下Esc键,则退出
        ElseIf Err Then
            RowHeight = DimTxt: Err.Clear '如果用户按下 enter 按钮或者输入有误,使用默认值
        End If
    End If
   
    Set ssText = ThisDrawing.SelectionSets.Add("Text")
    '定义过滤机制
    Dim filterType(0) As Integer
    Dim filterData(0) As Variant
    filterType(0) = 0
    filterData(0) = "TEXT"
    '提示用户在屏幕上选择文字
    ssText.SelectOnScreen filterType, filterData
   
    '对选择的插入点进行排序
    '   只对Y方向进行排序
    '   不对X方向进行排序
    N = ssText.Count - 1
    ReDim Y(N)
    ReDim Index(N)
    '           读取Y坐标到数组Y()中
    '           没有排序之前Text在选择集中的序号并没有变化,仍然是0、1、2、3……
    For i = 0 To N
        Set acText = ssText.item(i)
        Y(i) = acText.insertionPoint(1)
        Index(i) = i
        '检测赋值是否正确
        'ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        'ThisDrawing.Utility.Prompt Y(i) & vbCrLf
    Next i
    '           对数组Y()排序
    For i = 0 To N - 1
        For j = i + 1 To N
            '如果前一个比后面小的话,则把它的序号和后面的交换。
            If Y(i) <= Y(j) Then
                '交换Y坐标
                Temp = Y(i)
                Y(i) = Y(j)
                Y(j) = Temp
                '交换Text在选择集中的位置
                Temp = Index(i)
                Index(i) = Index(j)
                Index(j) = Temp
            End If
        Next j
    Next i
    '检测排序是否正确
    'ThisDrawing.Utility.Prompt "_______________" & vbCrLf
    'For i = 0 To n
    '    ThisDrawing.Utility.Prompt Index(i) & vbCrLf
    '    Set acText = ssText.item(Index(i))
    '    ThisDrawing.Utility.Prompt acText.insertionPoint(1) & vbCrLf
    'Next
    '对选择集中的文字对象进行操作
    '根据第一个对象的位置确定基点
    Set acText = ssText.item(Index(0))
    'MsgBox acText.insertionPoint(0)
    TextFirstPoint(0) = acText.insertionPoint(0)
    TextFirstPoint(1) = acText.insertionPoint(1)
    TextFirstPoint(2) = acText.insertionPoint(2)
    '调整文字行距和对齐
    For i = 0 To N
        ThisDrawing.Utility.Prompt Index(i) & vbCrLf
        Set acText = ssText.item(Index(i))
        If S = 1 Then
            TextNextPoint(0) = TextFirstPoint(0)
            TextNextPoint(1) = acText.insertionPoint(1)     'y坐标不变
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        ElseIf S = 2 Then
            '将RowHeight的值与相对基点的位置叠加,然后进行移动操作
            TextNextPoint(0) = TextFirstPoint(0)
            TextNextPoint(1) = TextFirstPoint(1) - (RowHeight * i)
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        ElseIf S = 3 Then
            '将RowHeight的值与相对基点的位置叠加,然后进行移动操作
            TextNextPoint(0) = acText.insertionPoint(0)     'x坐标不变
            TextNextPoint(1) = TextFirstPoint(1) - (RowHeight * i)
            TextNextPoint(2) = acText.insertionPoint(2)     'z坐标不变
        End If
        acText.Move acText.insertionPoint, TextNextPoint
    Next
    '删除选择集
    ThisDrawing.SelectionSets.item("Text").Delete
    ThisDrawing.Application.Update
End Function
'文字左对齐
Sub WZZDQ()
    TextAlign 1
End Sub
'文字平均行距左对齐
Sub WZPJHJZDQ()
    TextAlign 2
End Sub
'文字平均行距
Sub WZPJHJ()
    TextAlign 3
End Sub