CAD-文字按坐标从左到右，从下到上排序（2018.10.17新增归并排序）！

fangmin723

最近在接触cad VBA的坐标排序，在明经里面也找到不少，但是效果不是很满意，自己就在前人的基础上重写改良了一下！

网上摘录的 十大经典排序算法（动图演示）在14楼，点击蓝色文字即达！

下面这个是我自己代码演示效果：

这是在本论坛里面找到的，一次性框选没有问题，但是一个一个点选的时候就出现了问题，演示效果如下：
zzyong00版主的帖子：http://bbs.mjtd.com/forum.php?mo ... 364&fromuid=7316343

代码如下：

1. Sub DealText()
   
2.     Dim objSset As Object, objtrans As Object, objEntArr As New Collection, i As Integer, j As Integer
   
3.     Set zwdoc = AcadApplication.ActiveDocument
   
4.     SelectAllText zwdoc, objSset
   
5.     For i = 0 To objSset.Count - 1
   
6.         objEntArr.Add objSset.Item(i)
   
7.     Next i
   
8.     If objEntArr.Count > 0 Then
   
9.         SortYup objEntArr
   
10.         Dim pt As Variant, colObjArr() As New Collection, k As Long, objTmp As Object, ro%, n%
    
11.         ro = 0
    
12.         ReDim colObjArr(ro)
    
13.         Set pt = objEntArr(1)
    
14.         basept1 = pt.InsertionPoint
    
15.         For i = 1 To objEntArr.Count
    
16.             basept2 = objEntArr(i).InsertionPoint
    
17.             If Abs(basept1(1) - basept2(1)) < (pt.Height / 2#) Then
    
18.                 colObjArr(ro).Add objEntArr(i)
    
19.             Else
    
20.                 ro = ro + 1
    
21.                 ReDim Preserve colObjArr(ro)
    
22.                 Set pt = objEntArr(i)
    
23.                 basept1 = pt.InsertionPoint
    
24.                 colObjArr(ro).Add objEntArr(i)
    
25.             End If
    
26.         Next i
    
27.         n = 1
    
28.         For i = 0 To UBound(colObjArr)
    
29.             SortXup colObjArr(i)
    
30.             For j = 1 To colObjArr(i).Count
    
31.                 'MsgBox colObjArr(i).Item(j).TextString
    
32.                 colObjArr(i).Item(j).TextString = colObjArr(i).Item(j).TextString & CStr(n)
    
33.                 n = n + 1
    
34.             Next j
    
35.         Next i
    
36.     End If
    
37. End Sub
    
38. Private Sub SelectAllText(ByVal App As Object, objSset As Object, Optional ByVal strSsetname As String = "SELECTION~TEXT~1111")
    
39.       On Error GoTo err1
    
40.       Dim flag As Boolean
    
41.       flag = False
    
42.       For Each objSset In App.SelectionSets
    
43.             If objSset.Name = strSsetname Then
    
44.                   flag = True
    
45.                   Exit For
    
46.             End If
    
47.       Next
    
48.       If flag Then objSset.Delete      '创建集合，如集存在，则删除，再新建
    
49.       Set objSset = App.SelectionSets.Add(strSsetname)
    
50.       Dim gpCode(0)    As Integer
    
51.       Dim dataValue(0) As Variant
    
52.       gpCode(0) = 0
    
53.       dataValue(0) = "text,mtext"
    
54.       Dim groupCode As Variant, dataCode As Variant
    
55.       groupCode = gpCode
    
56.       dataCode = dataValue
    
57.       objSset.SelectOnScreen groupCode, dataCode
    
58.       Exit Sub
    
59. err1:
    
60.       Debug.Print Err.Description
    
61.       Err.Clear
    
62. End Sub

Sub DealText()<br />     Dim objSset As Object, objtrans As Object, objEntArr As New Collection, i As Integer, j As Integer<br />     Set zwdoc = AcadApplication.ActiveDocument<br />     SelectAllText zwdoc, objSset<br />     For i = 0 To objSset.Count - 1<br />         objEntArr.Add objSset.Item(i)<br />     Next i<br />     If objEntArr.Count > 0 Then<br />         SortYup objEntArr<br />         Dim pt As Variant, colObjArr() As New Collection, k As Long, objTmp As Object, ro%, n%<br />         ro = 0<br />         ReDim colObjArr(ro)<br />         Set pt = objEntArr(1)<br />         basept1 = pt.InsertionPoint<br />         For i = 1 To objEntArr.Count<br />             basept2 = objEntArr(i).InsertionPoint<br />             If Abs(basept1(1) - basept2(1)) < (pt.Height / 2#) Then<br />                 colObjArr(ro).Add objEntArr(i)<br />             Else<br />                 ro = ro + 1<br />                 ReDim Preserve colObjArr(ro)<br />                 Set pt = objEntArr(i)<br />                 basept1 = pt.InsertionPoint<br />                 colObjArr(ro).Add objEntArr(i)<br />             End If<br />         Next i<br />         n = 1<br />         For i = 0 To UBound(colObjArr)<br />             SortXup colObjArr(i)<br />             For j = 1 To colObjArr(i).Count<br />                 'MsgBox colObjArr(i).Item(j).TextString<br />                 colObjArr(i).Item(j).TextString = colObjArr(i).Item(j).TextString & CStr(n)<br />                 n = n + 1<br />             Next j<br />         Next i<br />     End If<br /> End Sub<br /> Private Sub SelectAllText(ByVal App As Object, objSset As Object, Optional ByVal strSsetname As String = "SELECTION~TEXT~1111")<br />       On Error GoTo err1<br />       Dim flag As Boolean<br />       flag = False<br />       For Each objSset In App.SelectionSets<br />             If objSset.Name = strSsetname Then<br />                   flag = True<br />                   Exit For<br />             End If<br />       Next<br />       If flag Then objSset.Delete      '创建集合，如集存在，则删除，再新建<br />       Set objSset = App.SelectionSets.Add(strSsetname)<br />       Dim gpCode(0)    As Integer<br />       Dim dataValue(0) As Variant<br />       gpCode(0) = 0<br />       dataValue(0) = "text,mtext"<br />       Dim groupCode As Variant, dataCode As Variant<br />       groupCode = gpCode<br />       dataCode = dataValue<br />       objSset.SelectOnScreen groupCode, dataCode<br />       Exit Sub<br /> err1:<br />       Debug.Print Err.Description<br />       Err.Clear<br /> End Sub

-------------------------------------------------------------------------------------------------------------------
文字坐标排序方法：（含冒牌排序和归并排序）
经本人测试，冒牌排序和归并排序的速度天壤之别，用2940个文字进行排序：
冒牌排序耗时：2分20多秒，
归并排序耗时：1秒！

按xy轴升降排序---单轴单序

1. '按X排序,从左到右排序
   
2. Private Function SortXup(ByRef objEntArr As Collection)
   
3.     Dim objtrans As Object
   
4.     For i = objEntArr.Count - 1 To 1 Step -1
   
5.             For j = 1 To i
   
6.                 basept1 = objEntArr(j).InsertionPoint
   
7.                 basept2 = objEntArr(j + 1).InsertionPoint
   
8.                 If basept1(0) > basept2(0) Then
   
9.                     Set objtrans = objEntArr(j)
   
10.                     objEntArr.Remove j
    
11.                     objEntArr.Add objtrans, , , j
    
12.                 End If
    
13.             Next j
    
14.         Next i
    
15. End Function
    
16. '按X排序,从右到左排序
    
17. Private Function SortXdown(ByRef objEntArr As Collection)
    
18.     Dim objtrans As Object
    
19.     For i = objEntArr.Count - 1 To 1 Step -1
    
20.             For j = 1 To i
    
21.                 basept1 = objEntArr(j).InsertionPoint
    
22.                 basept2 = objEntArr(j + 1).InsertionPoint
    
23.                 If basept1(0) < basept2(0) Then
    
24.                     Set objtrans = objEntArr(j)
    
25.                     objEntArr.Remove j
    
26.                     objEntArr.Add objtrans, , , j
    
27.                 End If
    
28.             Next j
    
29.         Next i
    
30. End Function
    
31. '按Y排序,从下到上排序
    
32. Private Function SortYup(ByRef objEntArr As Collection)
    
33.     Dim objtrans As Object
    
34.     For i = objEntArr.Count - 1 To 1 Step -1
    
35.             For j = 1 To i
    
36.                 basept1 = objEntArr(j).InsertionPoint
    
37.                 basept2 = objEntArr(j + 1).InsertionPoint
    
38.                 If basept1(1) > basept2(1) Then
    
39.                     Set objtrans = objEntArr(j)
    
40.                     objEntArr.Remove j
    
41.                     objEntArr.Add objtrans, , , j
    
42.                 End If
    
43.             Next j
    
44.         Next i
    
45. End Function
    
46. '按Y排序,从上到下排序
    
47. Private Function SortYdown(ByRef objEntArr As Collection)
    
48.     Dim objtrans As Object
    
49.     For i = objEntArr.Count - 1 To 1 Step -1
    
50.             For j = 1 To i
    
51.                 basept1 = objEntArr(j).InsertionPoint
    
52.                 basept2 = objEntArr(j + 1).InsertionPoint
    
53.                 If basept1(1) < basept2(1) Then
    
54.                     Set objtrans = objEntArr(j)
    
55.                     objEntArr.Remove j
    
56.                     objEntArr.Add objtrans, , , j
    
57.                 End If
    
58.             Next j
    
59.         Next i
    
60. End Function

'按X排序,从左到右排序<br /> Private Function SortXup(ByRef objEntArr As Collection)<br />     Dim objtrans As Object<br />     For i = objEntArr.Count - 1 To 1 Step -1<br />             For j = 1 To i<br />                 basept1 = objEntArr(j).InsertionPoint<br />                 basept2 = objEntArr(j + 1).InsertionPoint<br />                 If basept1(0) > basept2(0) Then<br />                     Set objtrans = objEntArr(j)<br />                     objEntArr.Remove j<br />                     objEntArr.Add objtrans, , , j<br />                 End If<br />             Next j<br />         Next i<br /> End Function<br /> '按X排序,从右到左排序<br /> Private Function SortXdown(ByRef objEntArr As Collection)<br />     Dim objtrans As Object<br />     For i = objEntArr.Count - 1 To 1 Step -1<br />             For j = 1 To i<br />                 basept1 = objEntArr(j).InsertionPoint<br />                 basept2 = objEntArr(j + 1).InsertionPoint<br />                 If basept1(0) < basept2(0) Then<br />                     Set objtrans = objEntArr(j)<br />                     objEntArr.Remove j<br />                     objEntArr.Add objtrans, , , j<br />                 End If<br />             Next j<br />         Next i<br /> End Function<br /> '按Y排序,从下到上排序<br /> Private Function SortYup(ByRef objEntArr As Collection)<br />     Dim objtrans As Object<br />     For i = objEntArr.Count - 1 To 1 Step -1<br />             For j = 1 To i<br />                 basept1 = objEntArr(j).InsertionPoint<br />                 basept2 = objEntArr(j + 1).InsertionPoint<br />                 If basept1(1) > basept2(1) Then<br />                     Set objtrans = objEntArr(j)<br />                     objEntArr.Remove j<br />                     objEntArr.Add objtrans, , , j<br />                 End If<br />             Next j<br />         Next i<br /> End Function<br /> '按Y排序,从上到下排序<br /> Private Function SortYdown(ByRef objEntArr As Collection)<br />     Dim objtrans As Object<br />     For i = objEntArr.Count - 1 To 1 Step -1<br />             For j = 1 To i<br />                 basept1 = objEntArr(j).InsertionPoint<br />                 basept2 = objEntArr(j + 1).InsertionPoint<br />                 If basept1(1) < basept2(1) Then<br />                     Set objtrans = objEntArr(j)<br />                     objEntArr.Remove j<br />                     objEntArr.Add objtrans, , , j<br />                 End If<br />             Next j<br />         Next i<br /> End Function

vba  6合一排序方法：xyz升降序排序！

1. '按文字位置坐标排序:
   
2. 'objEntArr-文字集合；
   
3. 'axis-对应轴的索引，默认0->X，1->Y，2->Z；
   
4. 'updown-升序还是降序排列，默认升序True，降序False
   
5. Private Function PointSort(ByRef objEntArr As Collection, Optional ByRef axis As Integer = 0, Optional ByRef updown As Boolean = True)
   
6.     Dim objtrans As Object, result As Boolean
   
7.     For i = objEntArr.Count - 1 To 1 Step -1
   
8.             For j = 1 To i
   
9.                 basept1 = objEntArr(j).InsertionPoint
   
10.                 basept2 = objEntArr(j + 1).InsertionPoint
    
11.                 If updown Then
    
12.                     result = basept1(axis) > basept2(axis)
    
13.                 Else
    
14.                     result = basept1(axis) < basept2(axis)
    
15.                 End If
    
16.                 If result Then
    
17.                     Set objtrans = objEntArr(j)
    
18.                     objEntArr.Remove j
    
19.                     objEntArr.Add objtrans, , , j
    
20.                 End If
    
21.             Next j
    
22.         Next i
    
23. End Function
    

'按文字位置坐标排序:<br /> 'objEntArr-文字集合；<br /> 'axis-对应轴的索引，默认0->X，1->Y，2->Z；<br /> 'updown-升序还是降序排列，默认升序True，降序False<br /> Private Function PointSort(ByRef objEntArr As Collection, Optional ByRef axis As Integer = 0, Optional ByRef updown As Boolean = True)<br />     Dim objtrans As Object, result As Boolean<br />     For i = objEntArr.Count - 1 To 1 Step -1<br />             For j = 1 To i<br />                 basept1 = objEntArr(j).InsertionPoint<br />                 basept2 = objEntArr(j + 1).InsertionPoint<br />                 If updown Then<br />                     result = basept1(axis) > basept2(axis)<br />                 Else<br />                     result = basept1(axis) < basept2(axis)<br />                 End If<br />                 If result Then<br />                     Set objtrans = objEntArr(j)<br />                     objEntArr.Remove j<br />                     objEntArr.Add objtrans, , , j<br />                 End If<br />             Next j<br />         Next i<br /> End Function<br />

归并排序：

1. '按文字位置坐标排序:
   
2. 'Arr-文字集合；
   
3. 'axis-对应轴的索引，默认0->X，1->Y，2->Z；
   
4. 'updown-升序还是降序排列，默认升序True，降序False
   
5. Function PointMergeSort(ByRef arr As Collection, Optional ByRef axis As Integer = 0, Optional ByRef updown As Boolean = True)
   
6.     MergeSort arr, 1, arr.COUNT, axis, updown
   
7. End Function
   
8. Function MergeSort(ByRef arr As Collection, ByRef ArrMin As Integer, ByRef ArrMax As Integer, ByRef axis As Integer, ByRef updown As Boolean)
   
9.     If ArrMax > ArrMin Then
   
10.         Dim ArrMid As Integer
    
11.         ArrMid = Int((ArrMin + ArrMax) / 2)
    
12.         MergeSort arr, ArrMin, ArrMid, axis, updown
    
13.         MergeSort arr, ArrMid + 1, ArrMax, axis, updown
    
14.         Merge arr, ArrMin, ArrMid, ArrMax, axis, updown
    
15.     End If
    
16. End Function
    
17. Function Merge(ByRef arr As Collection, ByRef ArrMin As Integer, ByRef ArrMid As Integer, ByRef ArrMax As Integer, axis As Integer, updown As Boolean)
    
18.     Dim Temp() As Object, result As Boolean
    
19.     ArrLen = ArrMax - ArrMin + 1
    
20.     i = ArrMin
    
21.     j = ArrMid + 1
    
22.     k = ArrMin
    
23.     ReDim Temp(ArrMin To ArrMax)
    
24.     While i <= ArrMid And j <= ArrMax
    
25.         basept1 = arr.Item(i).InsertionPoint
    
26.         basept2 = arr.Item(j).InsertionPoint
    
27.         If updown Then
    
28.             result = basept1(axis) < basept2(axis)
    
29.         Else
    
30.             result = basept1(axis) > basept2(axis)
    
31.         End If
    
32.         If result Then
    
33.             Set Temp(k) = arr.Item(i)
    
34.             k = k + 1
    
35.             i = i + 1
    
36.         Else
    
37.             Set Temp(k) = arr.Item(j)
    
38.             k = k + 1
    
39.             j = j + 1
    
40.         End If
    
41.     Wend
    
42.     While i <= ArrMid
    
43.         Set Temp(k) = arr.Item(i)
    
44.         k = k + 1
    
45.         i = i + 1
    
46.     Wend
    
47.     While j <= ArrMax
    
48.         Set Temp(k) = arr.Item(j)
    
49.         k = k + 1
    
50.         j = j + 1
    
51.     Wend
    
52.     For i = ArrMin To ArrMax
    
53.         arr.Add Temp(i), , , i
    
54.         arr.Remove (i)
    
55.     Next
    
56. End Function
    

'按文字位置坐标排序:<br /> 'Arr-文字集合；<br /> 'axis-对应轴的索引，默认0->X，1->Y，2->Z；<br /> 'updown-升序还是降序排列，默认升序True，降序False<br /> Function PointMergeSort(ByRef arr As Collection, Optional ByRef axis As Integer = 0, Optional ByRef updown As Boolean = True)<br />     MergeSort arr, 1, arr.COUNT, axis, updown<br /> End Function<br /> Function MergeSort(ByRef arr As Collection, ByRef ArrMin As Integer, ByRef ArrMax As Integer, ByRef axis As Integer, ByRef updown As Boolean)<br />     If ArrMax > ArrMin Then<br />         Dim ArrMid As Integer<br />         ArrMid = Int((ArrMin + ArrMax) / 2)<br />         MergeSort arr, ArrMin, ArrMid, axis, updown<br />         MergeSort arr, ArrMid + 1, ArrMax, axis, updown<br />         Merge arr, ArrMin, ArrMid, ArrMax, axis, updown<br />     End If<br /> End Function<br /> Function Merge(ByRef arr As Collection, ByRef ArrMin As Integer, ByRef ArrMid As Integer, ByRef ArrMax As Integer, axis As Integer, updown As Boolean)<br />     Dim Temp() As Object, result As Boolean<br />     ArrLen = ArrMax - ArrMin + 1<br />     i = ArrMin<br />     j = ArrMid + 1<br />     k = ArrMin<br />     ReDim Temp(ArrMin To ArrMax)<br />     While i <= ArrMid And j <= ArrMax<br />         basept1 = arr.Item(i).InsertionPoint<br />         basept2 = arr.Item(j).InsertionPoint<br />         If updown Then<br />             result = basept1(axis) < basept2(axis)<br />         Else<br />             result = basept1(axis) > basept2(axis)<br />         End If<br />         If result Then<br />             Set Temp(k) = arr.Item(i)<br />             k = k + 1<br />             i = i + 1<br />         Else<br />             Set Temp(k) = arr.Item(j)<br />             k = k + 1<br />             j = j + 1<br />         End If<br />     Wend<br />     While i <= ArrMid<br />         Set Temp(k) = arr.Item(i)<br />         k = k + 1<br />         i = i + 1<br />     Wend<br />     While j <= ArrMax<br />         Set Temp(k) = arr.Item(j)<br />         k = k + 1<br />         j = j + 1<br />     Wend<br />     For i = ArrMin To ArrMax<br />         arr.Add Temp(i), , , i<br />         arr.Remove (i)<br />     Next<br /> End Function<br />

mikewolf2k

fangmin723 发表于 2018-10-17 13:53
好了，新增加归并排序，速度快的起飞

递归的算法有个问题，如果对于有序的序列，递归的嵌套深度会大大增加，导致溢出出错。比如同一段程序，可以轻松排序10000个无序的数列，但是对于有序的数列，只能排1988个，再多就Out of stack space了。

fangmin723

zzyong00 发表于 2018-10-17 16:37
我这里有个排序的帖子，共同研究一下。
http://bbs.mjtd.com/thread-113042-1-1.html

还是版主厉害，有写排序稳定性比较差，建议还是助攻稳定性较强和速度快的！

fangmin723

zzyong00 发表于 2018-10-16 12:34
写代码“难度”低点好，不合看的很明白。
我哪个，点选+框选，会出错误，这是个比较奇怪的事儿，你调试出 ...

没有，不知道啥原因，我看了下，我那么点选后，选择集里面很多的空值，不知道和这个有没有关系，我也试着去找原因，但没找到！

mikewolf2k

友情提示下，对于不同对齐方式的文字，其对齐点不一样，有的是alignmentpoint。

fangmin723

mikewolf2k 发表于 2018-10-16 09:43
友情提示下，对于不同对齐方式的文字，其对齐点不一样，有的是alignmentpoint。

谢谢指导，vab从来没有接触过CAD的vba，这还是第一次，之前接触的都是coredraw的vba

再请教一下，四个排序如何合成一个呢

mikewolf2k

在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再加个判断，比如如果Y排序就是 If basept1(1) > basept2(1)
如果降序就是小于号。

fangmin723

mikewolf2k 发表于 2018-10-16 11:32
在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再 ...

这样应该没错吧！
见顶楼！

zzyong00

写代码“难度”低点好，不合看的很明白。
我哪个，点选+框选，会出错误，这是个比较奇怪的事儿，你调试出原因了吗？

fangmin723

mikewolf2k 发表于 2018-10-16 11:32
在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再 ...

目前就知道冒泡法

664571221

牛逼的人呵呵呵呵

白色微風1991

學習謝謝樓主