CAD-文字按坐标从左到右，从下到上排序（2018.10.17新增归并排序）！
本帖最后由 fangmin723 于 2018-10-23 07:51 编辑最近在接触cad VBA的坐标排序，在明经里面也找到不少，但是效果不是很满意，自己就在前人的基础上重写改良了一下！
网上摘录的 十大经典排序算法（动图演示）在14楼，点击蓝色文字即达！
下面这个是我自己代码演示效果：
这是在本论坛里面找到的，一次性框选没有问题，但是一个一个点选的时候就出现了问题，演示效果如下：
zzyong00版主的帖子：http://bbs.mjtd.com/forum.php?mo ... 364&fromuid=7316343
代码如下：
Sub DealText()
Dim objSset As Object, objtrans As Object, objEntArr As New Collection, i As Integer, j As Integer
Set zwdoc = AcadApplication.ActiveDocument
SelectAllText zwdoc, objSset
For i = 0 To objSset.Count - 1
objEntArr.Add objSset.Item(i)
Next i
If objEntArr.Count > 0 Then
SortYup objEntArr
Dim pt As Variant, colObjArr() As New Collection, k As Long, objTmp As Object, ro%, n%
ro = 0
ReDim colObjArr(ro)
Set pt = objEntArr(1)
basept1 = pt.InsertionPoint
For i = 1 To objEntArr.Count
basept2 = objEntArr(i).InsertionPoint
If Abs(basept1(1) - basept2(1)) < (pt.Height / 2#) Then
colObjArr(ro).Add objEntArr(i)
Else
ro = ro + 1
ReDim Preserve colObjArr(ro)
Set pt = objEntArr(i)
basept1 = pt.InsertionPoint
colObjArr(ro).Add objEntArr(i)
End If
Next i
n = 1
For i = 0 To UBound(colObjArr)
SortXup colObjArr(i)
For j = 1 To colObjArr(i).Count
'MsgBox colObjArr(i).Item(j).TextString
colObjArr(i).Item(j).TextString = colObjArr(i).Item(j).TextString & CStr(n)
n = n + 1
Next j
Next i
End If
End Sub
Private Sub SelectAllText(ByVal App As Object, objSset As Object, Optional ByVal strSsetname As String = "SELECTION~TEXT~1111")
On Error GoTo err1
Dim flag As Boolean
flag = False
For Each objSset In App.SelectionSets
If objSset.Name = strSsetname Then
flag = True
Exit For
End If
Next
If flag Then objSset.Delete '创建集合，如集存在，则删除，再新建
Set objSset = App.SelectionSets.Add(strSsetname)
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "text,mtext"
Dim groupCode As Variant, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
objSset.SelectOnScreen groupCode, dataCode
Exit Sub
err1:
Debug.Print Err.Description
Err.Clear
End Sub
-------------------------------------------------------------------------------------------------------------------
文字坐标排序方法：（含冒牌排序和归并排序）
**** Hidden Message *****
fangmin723 发表于 2018-10-17 13:53
好了，新增加归并排序，速度快的起飞
递归的算法有个问题，如果对于有序的序列，递归的嵌套深度会大大增加，导致溢出出错。比如同一段程序，可以轻松排序10000个无序的数列，但是对于有序的数列，只能排1988个，再多就Out of stack space了。 本帖最后由 fangmin723 于 2018-10-18 07:51 编辑
zzyong00 发表于 2018-10-17 16:37
我这里有个排序的帖子，共同研究一下。
http://bbs.mjtd.com/thread-113042-1-1.html还是版主厉害，有写排序稳定性比较差，建议还是助攻稳定性较强和速度快的！
zzyong00 发表于 2018-10-16 12:34
写代码“难度”低点好，不合看的很明白。
我哪个，点选+框选，会出错误，这是个比较奇怪的事儿，你调试出 ...
没有，不知道啥原因，我看了下，我那么点选后，选择集里面很多的空值，不知道和这个有没有关系，我也试着去找原因，但没找到！ 友情提示下，对于不同对齐方式的文字，其对齐点不一样，有的是alignmentpoint。 mikewolf2k 发表于 2018-10-16 09:43
友情提示下，对于不同对齐方式的文字，其对齐点不一样，有的是alignmentpoint。
谢谢指导，vab从来没有接触过CAD的vba，这还是第一次，之前接触的都是coredraw的vba
再请教一下，四个排序如何合成一个呢
在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再加个判断，比如如果Y排序就是 If basept1(1) > basept2(1)
如果降序就是小于号。 本帖最后由 fangmin723 于 2018-10-16 12:01 编辑
mikewolf2k 发表于 2018-10-16 11:32
在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再 ...
这样应该没错吧！
见顶楼！
写代码“难度”低点好，不合看的很明白。
我哪个，点选+框选，会出错误，这是个比较奇怪的事儿，你调试出原因了吗？ mikewolf2k 发表于 2018-10-16 11:32
在函数参数里加两个，XY排序，升降序。然后在循环语句里面
If basept1(0) > basept2(0) Then 这段外面再 ...
目前就知道冒泡法 牛逼的人呵呵呵呵
學習謝謝樓主