Here ya go...Very simple I just subtracted the Y insertion
point from the X insertion point and used the difference to
sort.
[code]
Option Explicit
Const dictKey = 1
Const dictItem = 2
Sub Stub()
Dim SS As AcadSelectionSet
Dim filType(0) As Integer
Dim filData(0)
filType(0) = 0
filData(0) = "TEXT"
Set SS = SSAdd("test")
SS.SelectOnScreen filType, filData
Dim Dict As Scripting.Dictionary
Set Dict = SSToDictionary(SS)
SortDictionary Dict, dictItem
'iterate sorted collection use Dict.Key to get
'the ents.
Dim i As Integer
Dim txt As AcadText
For i = 0 To Dict.Count - 1
Set txt = ThisDrawing.HandleToObject(Dict.Keys(i))
txt.TextString = i 'test only remove
'add to your table
Next i
Call SSRemove("test")
End Sub
'Add ss ents to Dictionary using ent.handle as key and ents
'(xIns - yIns) as item.
Function SSToDictionary(inSS As AcadSelectionSet) As Scripting.Dictionary
Dim i As Integer
Dim txt As AcadText
Dim Dict As New Scripting.Dictionary
For i = 0 To inSS.Count - 1
Set txt = inSS(i)
Dict.Add txt.Handle, _
(VBA.Round((CStr(txt.InsertionPoint(0) - txt.InsertionPoint(1))), 2))
Next i
Set SSToDictionary = Dict
End Function
Function SSAdd(inName As String) As AcadSelectionSet
On Error Resume Next
With ThisDrawing
.SelectionSets(inName).Delete
Set SSAdd = .SelectionSets.Add(inName)
End With
End Function
Sub SSRemove(inName As String)
On Error Resume Next
ThisDrawing.SelectionSets(inName).Delete
End Sub
'Modified MSDN Function
Function SortDictionary(objDict, intSort)
' declare our variables
Dim Dict()
Dim objKey
Dim strKey, strItem
Dim X, Y, Z
' get the dictionary count
Z = objDict.Count
' we need more than one item to warrant sorting
If Z > 1 Then
' create an array to store dictionary information
ReDim Dict(Z, 2)
X = 0
' populate the array
For Each objKey In objDict
Dict(X, dictKey) = (objKey)
Dict(X, dictItem) = (objDict(objKey))
X = X + 1
Next
' perform a a shell sort of the string array
For X = 0 To (Z - 2)
For Y = X To (Z - 1)
If Dict(X, intSort) > Dict(Y, intSort) Then
strKey = Dict(X, dictKey)
strItem = Dict(X, dictItem)
Dict(X, dictKey) = Dict(Y, dictKey)
Dict(X, dictItem) = Dict(Y, dictItem)
Dict(Y, dictKey) = strKey
Dict(Y, dictItem) = strItem
End If
Next
Next
' erase the contents of the dictionary object
objDict.RemoveAll
' repopulate the dictionary with the sorted information
For X = 0 To (Z - 1)
objDict.Add Dict(X, dictKey), Dict(X, dictItem)
Next
End If
End Function
[/code]
"Dan"
wrote in message
news:5213107@discussion.autodesk.com...
Thank you so much. I will attemp to incorporate this new code and
information into my routine.
Thanks again for all your help. When complete, this will save a tremendous
amount of rework.
Dan
"Paul Richardson" wrote in message
news:5213115@discussion.autodesk.com...
The nice thing is you don't have to know what is going in the sort
methods, just that it returns a sorted something for now...
That being said, here is code to add the x and y insertion coords to a 2d
array,
and then relate a sorted 2d array of insertion points back to entities in
your selection set.
You need a function to sort 2d arrays...google "Sort 2d coordinates" or such
[code]
Sub Stub()
Dim SS As AcadSelectionSet
Dim filType(0) As Integer
Dim filData(0)
'filter data for TEXT
filType(0) = 0
filData(0) = "TEXT"
Set SS = SSAdd("test")
SS.SelectOnScreen filType, filData
'create 2d array (x,y) same size as your SS
ReDim coords(SS.Count - 1, 1)
Dim txtEnt As AcadText
Dim i As Integer
For i = 0 To SS.Count - 1
Set txtEnt = SS(i)
coords(i, 0) = txtEnt.InsertionPoint(0)
coords(i, 1) = txtEnt.InsertionPoint(1)
Next i
'now you have an array of 2d coordinates, do
'a google for a function that will sort 2d
'coordinate arrays.
Dim j As Integer
'relate sorted coords back to your SS ents
'doesn't consider duplicate insertion points
For i = LBound(coords) To UBound(coords)
For j = 0 To SS.Count - 1
Set txtEnt = SS(j)
If txtEnt.InsertionPoint(0) = coords(i, 0) And _
txtEnt.InsertionPoint(1) = coords(i, 1) Then
'add text value to your table
Exit For
End If
Next j
Next i
Call SSRemove("test")
End Sub
Function SSAdd(inName As String) As AcadSelectionSet
On Error Resume Next
With ThisDrawing
.SelectionSets(inName).Delete
Set SSAdd = .SelectionSets.Add(inName)
End With
End Function
Sub SSRemove(inName As String)
On Error Resume Next
ThisDrawing.SelectionSets(inName).Delete
End Sub
[/code]
"Dan" wrote in message
news:5213024@discussion.autodesk.com...
I really do not understand most of what is happening in the heap sort
method, but I will learn it. I appreciate all the help. This code is much
more advanced than I have ever written. I was hoping to learn some new
tricks, but found a whole new area of coding I can explore.
Thanks again,
Dan