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

fjy602 发表于 2004-4-30 23:39:00

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

mccad 发表于 2004-5-1 07:07:00

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

fjy602 发表于 2004-5-1 17:02:00

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

雪山飞狐_lzh 发表于 2004-5-1 19:57:00

本帖最后由作者于 2004-5-2 16:15:15 编辑

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 发表于 2004-5-2 18:39:00

本帖最后由作者于 2004-5-6 7:43:30 编辑

这是改进版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 发表于 2004-5-3 19:44:00

这是我修改后的程序，由于我调试失败，我不知道我修改后是否与您程序结果是否一样？

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

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 End sub

我还在End sub 前加了几条语句(带下划线显示),本想读出Total内的数据，但调试失败(提示类型不匹配)，我不知道为什么会出错，忘告知出错原因和修正程序，谢谢!

雪山飞狐_lzh 发表于 2004-5-3 20:20:00

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

for each i in Total

for each j in i

debug.print j.textstring

next j

next i

fjy602 发表于 2004-5-3 20:52:00

我按下列语句已调试成功，谢谢!

按下面语句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 发表于 2004-5-3 21:06:00

上面有:

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

fjy602 发表于 2004-5-3 21:22:00

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

页: [1] 2

明经CAD社区's Archiver

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