选择集内的排序问题(高手都来比试一下)

supersky

现假设有选择集Sset，其中全为单行文字，由于过滤选择的时候是系统按照其绘图先后顺序而自动添加的，现如何通过其个单行文字的插入点坐标按从从左到右，自上而下的重新排序。此功能用为快速修改页码或图号等，比如一文件中有100幅图，可先查找“第*页”的文字将其添加到Sset中，然后自动修改页码。

请有兴趣的朋友及高手都来出个主意，怎么样给选择集内的元素排序。

fjfhgdwfn

　

Dim currInsertionPoint As Variant
currInsertionPoint = textObj.insertionPoint

只是比较insertionPoint（０）和insertionPoint（１）的大小问题啊。

兰州人

我的办法是autocad到EXCEL-SQL排序.

兰州人

fjfhgdwfn发表于2007-11-3 18:51:00　Dim currInsertionPoint As VariantcurrInsertionPoint = textObj.insertionPoint只是比较insertionPoint（０）和insertionPoint（１）的大小问题啊。

你考虑问题太简单了，insertionPoint（０）和insertionPoint（１）排序问题可是一个专题了。

排序，X轴排序，y轴排序。二维数组排序。

guojianguo

利用二维数组的已经是很简单的了，当然你如果只是对文字来排序的话，就可以用这种方法，比大小，自己想想就明白了。我做了一些排序的东西，是针对图框排序的，也是通过点来比较的，但是还不够好，不知道其他人还有什么更好的办法。

gdzhou

看看我这样写对不？
模块：

1. Public Type Point3d
2. x As Double
3. y As Double
4. z As Double
5. End Type

复制代码

代码

3. Sub RandApt()
4. '随机布点x=0~1000,y=0~1000
5. Dim pt As AcadPoint
6. Dim p() As Double
7. Dim pl As AcadLWPolyline
8. Dim i As Integer
9. ReDim p(7)
10. p(0) = 0: p(1) = 0
11. p(2) = 1000: p(3) = 0
12. p(4) = 1000: p(5) = 1000
13. p(6) = 0: p(7) = 1000
14. Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(p)
15. pl.Closed = True
16. ThisDrawing.Application.ZoomExtents
17. ReDim p(2)
18. For i = 0 To 1000
19. p(0) = Rnd * 1000
20. p(1) = Rnd * 1000
21. Set pt = ThisDrawing.ModelSpace.AddPoint(p)
22. Next i
23. End Sub
24. Sub Sort()
25. Dim pt As AcadPoint
26. Dim Ent As AcadEntity
27. Dim dt() As Point3d
28. Dim i As Integer
29. i = -1
30. For Each Ent In ThisDrawing.ModelSpace
31. If Ent.ObjectName = "AcDbPoint" Then
32. Set pt = Ent
33. i = i + 1
34. ReDim Preserve dt(i)
35. dt(i).x = Format(pt.Coordinates(0), "0")
36. dt(i).y = Format(pt.Coordinates(1), "0.00")
37. dt(i).z = Format(pt.Coordinates(2), "0.000")
38. End If
39. Next
40. '排序Xy
41. SSort dt, 2
42. Open "c:\tmp.txt" For Output As #1
43. For i = 0 To UBound(dt)
44.     Print #1, dt(i).x, dt(i).y, dt(i).z
45. Next i
46. Close #1
47. Shell "notepad.exe c:\tmp.txt", vbNormalFocus
48. MsgBox "Over"
49. End Sub
50. Function SSort(dt() As Point3d, k As Integer)
51. 'X=1、xy=2、xyz=3
52. Dim dt1() As Point3d
53. Dim i As Integer
54. Dim Ex As Boolean
55. i = UBound(dt)
56. ReDim dt1(i)
57. Dim N As Integer
58. N = i
59. dt1(0) = dt(0)
60. If k >= 1 Then '一次排序
61. For i = 1 To N
62. Ex = False
63.     For j = 0 To i - 1
64.         If dt(i).x <= dt1(j).x Then '插入
65.             For k = i To j + 1 Step -1
66.                 dt1(k) = dt1(k - 1)
67.             Next k
68.             dt1(j) = dt(i)
69.             Ex = True
70.             Exit For
71.         End If
72.     Next j
73.     If Ex = False Then '追加
74.         dt1(i) = dt(i)
75.     End If
76. Next i
78. End If
81. '==============='===============
82. If k >= 2 Then '二次排序
83. Dim tmp As Point3d
84. x1 = 0: x2 = 0
85. While x1 <= N
86. For i = x1 + 1 To N
87. If dt1(i).x = dt1(x1).x Then
88.     x2 = i
89. Else
90. Exit For
91. End If
92. Next i
93. If x2 - x1 > 0 Then
94.     For k = x1 To x2
95.     For j = x1 To x2 - k + x1 - 1
96.         If dt1(j).y > dt1(j + 1).y Then
97.         tmp = dt1(j + 1)
98.         dt1(j + 1) = dt1(j)
99.         dt1(j) = tmp
100.         End If
101.     Next j
102.     Next k
103. End If
104. x1 = i
105. x2 = x1
106. Wend
107. End If
108. '==============='===============
109. If k >= 3 Then '三次排序
110. x1 = 0: x2 = 0
111. While x1 <= N
112. For i = x1 + 1 To N
113. If dt1(i).x = dt1(x1).x And dt1(i).y = dt1(x1).y Then
114.     x2 = i
115. Else
116. Exit For
117. End If
118. Next i
119. If x2 - x1 > 0 Then
120.     For k = x1 To x2
121.     For j = x1 To x2 - k + x1 - 1
122.         If dt1(j + 1).y < dt1(j).y Then
123.         tmp = dt1(j + 1)
124.         dt1(j + 1) = dt1(j)
125.         dt1(j) = tmp
126.         End If
127.     Next j
128.     Next k
129. End If
130. x1 = i
131. x2 = x1
132. Wend
133. End If
134. '----------返回
135. For i = 0 To N
136. dt(i) = dt1(i)
137. Next i
138. End Function

Sub RandApt() '随机布点x=0~1000,y=0~1000 Dim pt As AcadPoint Dim p() As Double Dim pl As AcadLWPolyline Dim i As Integer ReDim p(7) p(0) = 0: p(1) = 0 p(2) = 1000: p(3) = 0 p(4) = 1000: p(5) = 1000 p(6) = 0: p(7) = 1000 Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(p) pl.Closed = True ThisDrawing.Application.ZoomExtents ReDim p(2) For i = 0 To 1000 p(0) = Rnd * 1000 p(1) = Rnd * 1000 Set pt = ThisDrawing.ModelSpace.AddPoint(p) Next i End Sub Sub Sort() Dim pt As AcadPoint Dim Ent As AcadEntity Dim dt() As Point3d Dim i As Integer i = -1 For Each Ent In ThisDrawing.ModelSpace If Ent.ObjectName = "AcDbPoint" Then Set pt = Ent i = i + 1 ReDim Preserve dt(i) dt(i).x = Format(pt.Coordinates(0), "0") dt(i).y = Format(pt.Coordinates(1), "0.00") dt(i).z = Format(pt.Coordinates(2), "0.000") End If Next '排序Xy SSort dt, 2 Open "c:\tmp.txt" For Output As #1 For i = 0 To UBound(dt)     Print #1, dt(i).x, dt(i).y, dt(i).z Next i Close #1 Shell "notepad.exe c:\tmp.txt", vbNormalFocus MsgBox "Over" End Sub Function SSort(dt() As Point3d, k As Integer) 'X=1、xy=2、xyz=3 Dim dt1() As Point3d Dim i As Integer Dim Ex As Boolean i = UBound(dt) ReDim dt1(i) Dim N As Integer N = i dt1(0) = dt(0) If k >= 1 Then '一次排序 For i = 1 To N Ex = False     For j = 0 To i - 1         If dt(i).x <= dt1(j).x Then '插入             For k = i To j + 1 Step -1                 dt1(k) = dt1(k - 1)             Next k             dt1(j) = dt(i)             Ex = True             Exit For         End If     Next j     If Ex = False Then '追加         dt1(i) = dt(i)     End If Next i End If '==============='=============== If k >= 2 Then '二次排序 Dim tmp As Point3d x1 = 0: x2 = 0 While x1 <= N For i = x1 + 1 To N If dt1(i).x = dt1(x1).x Then     x2 = i Else Exit For End If Next i If x2 - x1 > 0 Then     For k = x1 To x2     For j = x1 To x2 - k + x1 - 1         If dt1(j).y > dt1(j + 1).y Then         tmp = dt1(j + 1)         dt1(j + 1) = dt1(j)         dt1(j) = tmp         End If     Next j     Next k End If x1 = i x2 = x1 Wend End If '==============='=============== If k >= 3 Then '三次排序 x1 = 0: x2 = 0 While x1 <= N For i = x1 + 1 To N If dt1(i).x = dt1(x1).x And dt1(i).y = dt1(x1).y Then     x2 = i Else Exit For End If Next i If x2 - x1 > 0 Then     For k = x1 To x2     For j = x1 To x2 - k + x1 - 1         If dt1(j + 1).y < dt1(j).y Then         tmp = dt1(j + 1)         dt1(j + 1) = dt1(j)         dt1(j) = tmp         End If     Next j     Next k End If x1 = i x2 = x1 Wend End If '----------返回 For i = 0 To N dt(i) = dt1(i) Next i End Function

兰州人

6楼的解法，好好要研究一下。

supersky

谢谢高手的指点，非常有用，不过你好像误解了我的意思了，我不是准备给选择集内的对象按照坐标来排序，而是要让他排好序后这些图元还是在选择集内，只是需要排列选择集内图元的在选择集内的顺序。比如可以把sset.item(0)与sset.item(1)做比较，比较条件是其插入点的坐标从从上到下，从做到右，然后把sset.item(0)赋给sset.item(3),sset.item(0)赋为item(1)的值，在把SSET.ITEM(1)赋为item(3)的值。

兰州人

以下的排序方法：
不重复排序+冒泡排序方法

2. Sub als()  Dim xm, xm1
3.   Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity           
4.   aii = 0
5.   ReDim xm(60) As Long, xm1(60) As Long
6.   For Each Ent In ThisDrawing.ModelSpace   
7.     Select Case Ent.ObjectName
8.       Case "AcDbLine"
9.         Set ll = Ent
10.         xm(aii) = ll.EndPoint(0)
11.         xm1(aii) = ll.EndPoint(1)
12.         aii = aii + 1
13.      End Select
14.   Next Ent
15.   ReDim Preserve xm1(1000) As Long
16.   bb = xx(xm1)
17.   Dim abc() As Long
18.   ReDim abc(UBound(bb)) As Long
19.   For ii = 0 To UBound(bb)   
20.     abc(ii) = Val(bb(ii))   
21.   Next ii
22.   
23.   cc = Bubble_Sort(abc)
24.   For ii = 0 To UBound(cc)
25.     Debug.Print ii, "-", cc(ii)
26.   Next ii
27.   ReDim Preserve xm(1000) As Long
28.   bb = xx(xm)
29.   
30.   ReDim abc(UBound(bb)) As Long
31.   For ii = 0 To UBound(bb)
32.    
33.     abc(ii) = Val(bb(ii))
34.    
35.   Next ii
36.   
37.   ccc = Bubble_Sort(abc)
38.   For ii = 0 To UBound(ccc)
39.     Debug.Print ii, "-", ccc(ii)
40.   Next ii
41.   ReDim xm(0), xm1(0)
42. End Sub
43.    
44. Function xx(xm)
45.   Dim arr() As String, Temp() As String '声明变量
46.   Dim s%, r% '声明单值变量
47.     On Error Resume Next '启动一个错误处理程序
48.    
49.     r = 0 '初值
50.     s = UBound(xm)  '最大下标
51.    
52.     For i = 0 To s '循环
53.       Temp = Filter(arr, xm(i)) '搜索数组
54.       
55.       If UBound(Temp) = -1 Then '如果未找到
56.         ReDim Preserve arr(0 To r)  '定义动态数组大小
57.         arr(r) = xm(i) '把姓名复制到数组Arr()中。
58.         r = r + 1 '序号，自增1
59.       End If
60.     Next
61.     xx = arr
62. End Function
63. Function Bubble_Sort(Ary)
64.   Dim aryUBound, i, j
65.   aryUBound = UBound(Ary)
66.   For ii = 0 To aryUBound
67.     Ary(ii) = Val(Round(Ary(ii), 2))
68.   Next ii
69.   For i = 0 To aryUBound
70.     For j = i + 1 To aryUBound
71.       If Ary(i) < Ary(j) Then
72.         Swap Ary(i), Ary(j)
73.       End If
74.     Next
75.   Next
76.   Bubble_Sort = Ary
77. End Function
78. Function Swap(a, b)
79.   Dim tmp
80.   tmp = a
81.   a = b
82.   b = tmp
83. End Function

Sub als()  Dim xm, xm1   Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity              aii = 0   ReDim xm(60) As Long, xm1(60) As Long   For Each Ent In ThisDrawing.ModelSpace        Select Case Ent.ObjectName       Case "AcDbLine"         Set ll = Ent         xm(aii) = ll.EndPoint(0)         xm1(aii) = ll.EndPoint(1)         aii = aii + 1      End Select   Next Ent   ReDim Preserve xm1(1000) As Long   bb = xx(xm1)   Dim abc() As Long   ReDim abc(UBound(bb)) As Long   For ii = 0 To UBound(bb)        abc(ii) = Val(bb(ii))      Next ii      cc = Bubble_Sort(abc)   For ii = 0 To UBound(cc)     Debug.Print ii, "-", cc(ii)   Next ii   ReDim Preserve xm(1000) As Long   bb = xx(xm)      ReDim abc(UBound(bb)) As Long   For ii = 0 To UBound(bb)         abc(ii) = Val(bb(ii))       Next ii      ccc = Bubble_Sort(abc)   For ii = 0 To UBound(ccc)     Debug.Print ii, "-", ccc(ii)   Next ii   ReDim xm(0), xm1(0) End Sub     Function xx(xm)   Dim arr() As String, Temp() As String '声明变量   Dim s%, r% '声明单值变量     On Error Resume Next '启动一个错误处理程序         r = 0 '初值     s = UBound(xm)  '最大下标         For i = 0 To s '循环       Temp = Filter(arr, xm(i)) '搜索数组              If UBound(Temp) = -1 Then '如果未找到         ReDim Preserve arr(0 To r)  '定义动态数组大小         arr(r) = xm(i) '把姓名复制到数组Arr()中。         r = r + 1 '序号，自增1       End If     Next     xx = arr End Function Function Bubble_Sort(Ary)   Dim aryUBound, i, j   aryUBound = UBound(Ary)   For ii = 0 To aryUBound     Ary(ii) = Val(Round(Ary(ii), 2))   Next ii   For i = 0 To aryUBound     For j = i + 1 To aryUBound       If Ary(i) < Ary(j) Then         Swap Ary(i), Ary(j)       End If     Next   Next   Bubble_Sort = Ary End Function Function Swap(a, b)   Dim tmp   tmp = a   a = b   b = tmp End Function

兰州人

以上方法在处理AutoCAD的材料表处理中比较实用。