[VBA]如何实现选择集内的数据或对象按一定要求排序并生成新的选择集

fjy602

我的图形上有10个text,选择10个text，生成一个选择集，我想按10个text的插入点(insertpoint)的Y轴坐标点大小排序并生成一个新的选择集

mccad

这是排序问题，一般来说将所有的选择集中的对象及插入点坐标放到一个自定义数据类型中，然后按自定义数据类型中的某一项对整个自定义数据进行排序。
我写的对象均布程序就是这样做的。

fjy602

小生不才，能否给我一个例子，万分感谢。E-mail:fjy602@163.com

雪山飞狐_lzh

2. Public Function Sort(Texts As Variant, TextHeight As Double) As Collection
3. '将选择集、文本数组或文本集合按X轴和Y轴进行排序，返回一个集合的集合
4. Dim Total As New Collection
5. Dim pPnts As Collection
6. Dim Judge As Boolean
7. Dim i As AcadObject, j As Collection, k As Integer, l As Integer
8. Dim p1, p2, p3, p4
9. For Each i In Texts
10.        Judge = False
11.        For Each j In Total
12.        p1 = j(1).InsertionPoint: p2 = i.InsertionPoint
13.                If Abs(p1(1) - p2(1)) < TextHeight Then
14.                        For k = 1 To j.Count
15.                        p3 = j(k).InsertionPoint
16.                                If p3(0) >= p2(0) Then
17.                                        j.Add i, , k
18.                                        Judge = True
19.                                        Exit For
20.                                End If
21.                        Next k
22.                        If Not Judge Then j.Add i: Judge = True
23.                        Exit For
24.                End If
25.        Next j
26.        If Not Judge Then
27.                Set pPnts = New Collection
28.                pPnts.Add i
29.                For l = 1 To Total.Count
30.                        p4 = Total(l)(1).InsertionPoint
31.                        If p4(1) < p2(1) Then
32.                                Total.Add pPnts, , l
33.                                Judge = True
34.                                Exit For
35.                        End If
36.                Next l
37.                If Not Judge Then Total.Add pPnts
38.        End If
39. Next i
40. Set Sort = Total
41. End FunctionPublic Sub UnExplodeMText()
42. '将选择的多个Text或MText按X轴和Y轴连接为一个MText,即炸开MText的逆过程
43. On Error GoTo ErrClear
44. Dim pFilterType(0) As Integer, pFilter(0) As Variant
45. Dim pHeight As Double
46. Dim pText As String
47. Dim ss As AcadSelectionSet
48. Dim i, j, k As Integer
49. pFilterType(0) = 0: pFilter(0) = "Text,MText"
50. Set ss = ThisDrawing.SelectionSets.Add("*MergeTexts*")
51. ss.SelectOnScreen pFilterType, pFilter
52. pHeight = ss(0).Height
53. For Each i In Sort(ss, pHeight)
54. For Each j In i
55. pText = pText & j.TextString
56. Next j
57. pText = pText & "\P"
58. Next i
59. For k = 0 To ss.Count - 1
60. ss(k).Delete
61. Next k
62. ThisDrawing.ModelSpace.AddMText(ThisDrawing.Utility.GetPoint(, "请输入插入点:"), 0, pText).Height = pHeight
63. ErrClear:
64. ss.Delete
65. End Sub

Public Function Sort(Texts As Variant, TextHeight As Double) As Collection '将选择集、文本数组或文本集合按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 FunctionPublic Sub UnExplodeMText() '将选择的多个Text或MText按X轴和Y轴连接为一个MText,即炸开MText的逆过程 On Error GoTo ErrClear Dim pFilterType(0) As Integer, pFilter(0) As Variant Dim pHeight As Double Dim pText As String Dim ss As AcadSelectionSet Dim i, j, k As Integer pFilterType(0) = 0: pFilter(0) = "Text,MText" Set ss = ThisDrawing.SelectionSets.Add("*MergeTexts*") ss.SelectOnScreen pFilterType, pFilter pHeight = ss(0).Height For Each i In Sort(ss, pHeight) For Each j In i pText = pText & j.TextString Next j pText = pText & "\P" Next i For k = 0 To ss.Count - 1 ss(k).Delete Next k ThisDrawing.ModelSpace.AddMText(ThisDrawing.Utility.GetPoint(, "请输入插入点:"), 0, pText).Height = pHeight ErrClear: ss.Delete End Sub

雪山飞狐_lzh

这是改进版

2. Private Function MToS(MText As Variant) As Variant
3. '炸开MText并返回一个Text数组
4.        Dim i As Integer
5.        Dim ss As AcadSelectionSet
6.        Dim pTexts() As AcadObject
7.        ThisDrawing.ActiveSelectionSet.Clear
8.        ThisDrawing.SendCommand "Explode" & vbCr & "(handent " & Chr(34) _
9.                                                        & MText.Handle & Chr(34) & ")" & vbCr & vbCr       Set ss = ThisDrawing.ActiveSelectionSet
10.        ReDim pTexts(ss.Count - 1) As AcadObject
11.        For i = 0 To ss.Count - 1
12.        Set pTexts(i) = ss(i)
13.        Next i
14.        MToS = pTexts
15. End Function
16. Public Function Sort(Texts As Variant, TextHeight As Double) As Collection
17. '将选择集、Text数组或Text集合按X轴和Y轴进行排序，返回一个集合的集合
18. Dim Total As New Collection
19. Dim pPnts As Collection
20. Dim Judge As Boolean
21. Dim i As AcadObject, j As Collection, k As Integer, l As Integer
22. Dim p1, p2, p3, p4
23. For Each i In Texts
24.        Judge = False
25.        For Each j In Total
26.        p1 = j(1).InsertionPoint: p2 = i.InsertionPoint
27.                If Abs(p1(1) - p2(1)) < TextHeight Then
28.                        For k = 1 To j.Count
29.                        p3 = j(k).InsertionPoint
30.                                If p3(0) >= p2(0) Then
31.                                        j.Add i, , k
32.                                        Judge = True
33.                                        Exit For
34.                                End If
35.                        Next k
36.                        If Not Judge Then j.Add i: Judge = True
37.                        Exit For
38.                End If
39.        Next j
40.        If Not Judge Then
41.                Set pPnts = New Collection
42.                pPnts.Add i
43.                For l = 1 To Total.Count
44.                        p4 = Total(l)(1).InsertionPoint
45.                        If p4(1) < p2(1) Then
46.                                Total.Add pPnts, , l
47.                                Judge = True
48.                                Exit For
49.                        End If
50.                Next l
51.                If Not Judge Then Total.Add pPnts
52.        End If
53. Next i
54. Set Sort = Total
55. End Function
56. Public Sub UnExplodeMText()
57. '将选择的多个Text或MText按X轴和Y轴连接为一个MText,即炸开MText的逆过程
58. On Error Resume Next
59. Dim pFilterType(0) As Integer, pFilter(0) As Variant
60. Dim Ents(0) As AcadObject, l As AcadObject
61. Dim pHeight As Double
62. Dim pText As String
63. Dim pObjs As New Collection
64. Dim ss As AcadSelectionSet
65. Dim i, j, k As Integer
66. Set ss = ThisDrawing.SelectionSets.Add("*UnExplodeMText*")
67. If Err Then
68. Set ss = ThisDrawing.SelectionSets("*UnExplodeMText*")
69. Err.Clear
70. End If
71. ss.Clear
72. pFilterType(0) = 0: pFilter(0) = "Text,MText"
73. ss.SelectOnScreen pFilterType, pFilter
74. For Each l In ss
75. pObjs.Add l
76. Next l
77. ss.Delete
78. Debug.Print pObjs.Count
79. i = 1
80. Do While i <= pObjs.Count
81.        If UCase(pObjs(i).ObjectName) = "ACDBMTEXT" Then
82.        For Each j In MToS(pObjs(i))
83.        pObjs.Add j, , , i
84.        Next j
85.        pObjs.Remove i
86.        End If
87.        i = i + 1
88. Loop
89. Debug.Print pObjs.Count
90. pHeight = pObjs(1).Height
91. For Each i In Sort(pObjs, pHeight)
92. For Each j In i
93. pText = pText & j.TextString
94. Next j
95. pText = pText & "\P"
96. Next i
97. For k = 1 To pObjs.Count
98. pObjs(k).Delete
99. Next k
100. ThisDrawing.ModelSpace.AddMText(ThisDrawing.Utility.GetPoint(, "请输入插入点:"), 0, pText).Height = pHeight
101. ErrClear:
102. End Sub

Private Function MToS(MText As Variant) As Variant '炸开MText并返回一个Text数组        Dim i As Integer        Dim ss As AcadSelectionSet        Dim pTexts() As AcadObject        ThisDrawing.ActiveSelectionSet.Clear        ThisDrawing.SendCommand "Explode" & vbCr & "(handent " & Chr(34) _                                                        & MText.Handle & Chr(34) & ")" & vbCr & vbCr       Set ss = ThisDrawing.ActiveSelectionSet        ReDim pTexts(ss.Count - 1) As AcadObject        For i = 0 To ss.Count - 1        Set pTexts(i) = 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

fjy602

这是我修改后的程序，由于我调试失败，我不知道我修改后是否与您程序结果是否一样？ Sub sort1()
Dim Total As New Collection
Dim pPnts As Collection
Dim Judge As Boolean
Dim i As AcadText, j As Collection, k, a As Integer, l As Integer
Dim p1, p2, p3, p4
Dim textheight As Double
Dim ssetobjcount As Integer
Dim ssetobj As AcadSelectionSet
Dim va

If ThisDrawing.SelectionSets.Count <> 0 Then
For a = 0 To ThisDrawing.SelectionSets.Count - 1
Set ssetobj = ThisDrawing.SelectionSets.Item(a)
ssetobj.Delete
Next
End If Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 0
dataValue(0) = "TEXT" Dim FilterType As Variant, FilterData As Variant
FilterType = gpCode
FilterData = dataValue
Set ssetobj = ThisDrawing.SelectionSets.Add("texts")
ssetobj.SelectOnScreen FilterType, FilterData

ssetobjcount = ssetobj.Count
If ssetobjcount = 0 Then
Exit Sub
End If For Each i In ssetobj
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 [U]Dim entobj As AcadEntity
Dim text As AcadText
For a = 1 To Total.Count - 1
Set entobj = Total(a)
Set text = entobj
MsgBox RTrim(LTrim(text.textString))
Next a[/U]
End sub 我还在End sub 前加了几条语句(带下划线显示),本想读出Total内的数据，但调试失败(提示类型不匹配)，我不知道为什么会出错，忘告知出错原因和修正程序，谢谢!

雪山飞狐_lzh

Total是一个集合的集合,要引用用


for each i in Total


for each j in i


debug.print j.textstring


next j


next i

fjy602

我按下列语句已调试成功，谢谢! 按下面语句msgbox显示的是单个Text的文本内容，假如我想用msgbox显示同一行内Text对象的全部文本，我该如何呢？为昐，谢谢! For Each j In Total
For Each i In j
MsgBox j.Count
MsgBox i.textString
Next i
Next j

雪山飞狐_lzh

上面有: For Each i In Sort(ss, pHeight)
For Each j In i
pText = pText & j.TextString
Next j
pText = pText & "\P"
Next i

fjy602

我已调试成功，谢谢!!!!!