[求助]：txt到mtxt？哪位大虾有好工具啊

leer

cad的express工具中的将txt变为mtxt，似乎仍不够实用，如果是在一段txt的中间有空白，
这个空白处又有txt，哪转化的顺序是不能让人满意的，不知哪位仁兄有更好的工具呢？

雪山飞狐(lzh)

以前编过一个,可以处理text和mtext
[Code]
Private Function MToS(mtext As Variant) As Variant
'炸开MText并返回一个Text数组
    Dim i As Integer
    Dim ss As AcadSelectionSet
    Dim pTexts As New Collection
    ThisDrawing.ActiveSelectionSet.Clear
    ThisDrawing.SendCommand "Explode" & vbCr & "(handent " & Chr(34) _
                            & mtext.Handle & Chr(34) & ")" & vbCr & vbCr
    Set ss = ThisDrawing.ActiveSelectionSet
    For i = 0 To ss.Count - 1
        If UCase(ss(i).ObjectName) = "ACDBTEXT" Then pTexts.Add ss(i)
    Next i
    MToS = pTexts
End Function

Public Function Sort(Texts As Variant, TextHeight As Double) As Collection
'将选择集、Text数组或Text集合按X轴和Y轴进行排序，返回一个集合的集合
Dim Total As New Collection
Dim pPnts As Collection
Dim Judge As Boolean
Dim i As AcadObject, j As Collection, k As Integer, L As Integer
Dim p1, p2, p3, p4
For Each i In Texts
    Judge = False
    For Each j In Total
    p1 = j(1).insertionPoint: p2 = i.insertionPoint
        If Abs(p1(1) - p2(1)) < TextHeight Then
            For k = 1 To j.Count
            p3 = j(k).insertionPoint
                If p3(0) >= p2(0) Then
                    j.Add i, , k
                    Judge = True
                    Exit For
                End If
            Next k
            If Not Judge Then j.Add i: Judge = True
            Exit For
        End If
    Next j
    If Not Judge Then
        Set pPnts = New Collection
        pPnts.Add i
        For L = 1 To Total.Count
            p4 = Total(L)(1).insertionPoint
            If p4(1) < p2(1) Then
                Total.Add pPnts, , L
                Judge = True
                Exit For
            End If
        Next L
        If Not Judge Then Total.Add pPnts
    End If
Next i
Set Sort = Total
End Function

Public Sub UnExplodeMText()
'将选择的多个Text或MText按X轴和Y轴连接为一个MText,即炸开MText的逆过程
On Error Resume Next
Dim pFilterType(0) As Integer, pFilter(0) As Variant
Dim Ents(0) As AcadObject, L As AcadObject
Dim pHeight As Double
Dim pText As String
Dim pObjs As New Collection
Dim ss As AcadSelectionSet
Dim i, j, k As Integer
Set ss = ThisDrawing.SelectionSets.Add("*UnExplodeMText*")
If Err Then
Set ss = ThisDrawing.SelectionSets("*UnExplodeMText*")
Err.Clear
End If
ss.Clear
pFilterType(0) = 0: pFilter(0) = "Text,MText"
ss.SelectOnScreen pFilterType, pFilter
For Each L In ss
pObjs.Add L
Next L
ss.Delete
Debug.Print pObjs.Count
i = 1
Do While i <= pObjs.Count
    If UCase(pObjs(i).ObjectName) = "ACDBMTEXT" Then
    For Each j In MToS(pObjs(i))
    pObjs.Add j, , , i
    Next j
    pObjs.Remove i
    End If
    i = i + 1
Loop
Debug.Print pObjs.Count
pHeight = pObjs(1).height
For Each i In Sort(pObjs, pHeight)
For Each j In i
pText = pText & j.textString
Next j
pText = pText & "\P"
Next i
For k = 1 To pObjs.Count
pObjs(k).Delete
Next k
ThisDrawing.ModelSpace.AddMText(ThisDrawing.Utility.GetPoint(, "请输入插入点:"), 0, pText).height = pHeight
ErrClear:
End Sub
[/Code]