Sort an array of text objects by their X and Y insertion point values

[danderson.71652]

Please see attached drawing file in previous post for an example of my exact situation.
Thank you for your time.

[zoomharis]

"The best way to make your dreams come true is to Wake Up."
I like that!

Now only I came to know the real meaning of that sentence. It's 2.30 a.m here

I did not mean to rush or sound impatient with the crickets comment, I was trying to add a little humor to my ignorance.

Nice to hear that.

I believe this is exactly the direction I am going...I just need to incorporate it into my exiting code

Please look at the line "' PLEASE READ THIS COMMENT" in the code.

' PLEASE READ THIS COMMENT
'sorting goes here into array, then sort, then back into array, then into a new selectionset
'can this be done?

I think it can be done by keeping handles of the objects in the array. But not sure about that. I have to experiment with that. Again you have to be patient with me

har!s

[danderson.71652]

Oh, I do not have much to add, my brain is spent. I can wait. Thank you so much for you time, I have learned a great deal with this effort.

Thank you again

[zoomharis]

Hi Danderson,

I have rewritten my program to incorporate the selection set. Try how the code works now...

 
Sub SortTextByPos()
On Error Resume Next
Dim objTxt As AcadText
Dim objSSet As AcadSelectionSet
Dim gpCode(0) As Integer: Dim dataVal(0) As Variant
Set objSSet = ThisDrawing.SelectionSets.Add("TxtSet1")
gpCode(0) = 0: dataVal(0) = "Text"
ReSelect:
objSSet.SelectOnScreen gpCode, dataVal
If objSSet.Count <> 0 Then
	Dim TxtPnt As Variant
	Dim arTxtPnts() As Variant
	Dim TxtBasePnt(0 To 1) As Double
	Dim iDim As Integer
	iDim = 0
	ReDim Preserve arTxtPnts(objSSet.Count - 1, 2)
	For Each objTxt In objSSet
		If objTxt.Alignment = acAlignmentLeft Then
			TxtPnt = objTxt.InsertionPoint
		Else
			TxtPnt = objTxt.TextAlignmentPoint
		End If
		TxtBasePnt(0) = TxtPnt(0): TxtBasePnt(1) = TxtPnt(1)
		arTxtPnts(iDim, 0) = TxtPnt(0)
		arTxtPnts(iDim, 1) = TxtPnt(1)
		arTxtPnts(iDim, 2) = objTxt.Handle
		iDim = iDim + 1
	Next
	arTxtPnts = SortArrayByCoords(arTxtPnts)
	Dim arTxtObjs() As AcadText
	Dim objSortedSSet As AcadSelectionSet
	ReDim arTxtObjs(UBound(arTxtPnts))
	Set objSortedSSet = ThisDrawing.SelectionSets.Add("SS_Text1")
	For i = 0 To UBound(arTxtPnts)
		Set arTxtObjs(i) = ThisDrawing.HandleToObject(arTxtPnts(i, 2))
	Next
	objSortedSSet.AddItems arTxtObjs
	
	 '<-- Display values for checking -->
	Dim strOP As String
	For Each objTxt In objSortedSSet
		strOP = strOP & objTxt.TextString & vbCrLf
	Next
	MsgBox strOP
	objSortedSSet.Highlight True
	'<-- End display -->
	objSortedSSet.Delete
	objSSet.Delete
End If
If Err.Number <> 0 Then
	MsgBox Err.Description
	Err.Clear
End If
End Sub
Function SortArrayByCoords(ByVal arSource As Variant)
	Dim i As Integer
	Dim j As Integer
	Dim dblTmpVal(2)
	For i = UBound(arSource) To LBound(arSource) Step -1
	   For j = LBound(arSource) + 1 To i
	   '<-- Check for the X coordinates first and if they are equel -
	   '<-- compare the the Y coordinates -->
		 If ( _
				(arSource(j - 1, 0) > arSource(j, 0)) _
				Or ( _
				(arSource(j - 1, 0) = arSource(j, 0)) _
				And _
				(arSource(j - 1, 1) < arSource(j, 1)) _
				) _
			) Then
		   dblTmpVal(0) = arSource(j - 1, 0)
		   dblTmpVal(1) = arSource(j - 1, 1)
		   dblTmpVal(2) = arSource(j - 1, 2)
		   arSource(j - 1, 0) = arSource(j, 0)
		   arSource(j - 1, 1) = arSource(j, 1)
		   arSource(j - 1, 2) = arSource(j, 2)
		   arSource(j, 0) = dblTmpVal(0)
		   arSource(j, 1) = dblTmpVal(1)
		   arSource(j, 2) = dblTmpVal(2)
		 End If
	   Next j
	 Next i
  SortArrayByCoords = arSource
End Function

HTH
har!s

[danderson.71652]

I am almost complete with the implementation, I will post the code shortly!

[danderson.71652]

I have added the code into mine. The only thing left to figure out is Mtext.
In the example drawing file I have, one table's entities are just Text, and one Text and Mtext.

The code work flawless on just TEXT.

This is amazing, and congratulations on a fine job. I can't thank you enough.

See attached drawing.

Dan

Option Explicit
Sub FieldsToTableFinal()
Dim oSsets As AcadSelectionSets
Dim oSset As AcadSelectionSet
Dim oSset2 As AcadSelectionSet
Dim oTable As AcadTable
Dim oText As AcadText
Dim j, k, l, m As Long
Dim i, n As Integer
Dim FilterType(3) As Integer
Dim FilterData(3) As Variant
Dim insPt As Variant
Dim tmpStr As String
Dim basePnt As Variant
Dim celltxtchk As String
Dim oMText As AcadMText
Dim SSetSort As Variant

    FilterType(0) = -4
    FilterData(0) = "<or"
    FilterType(1) = 0
    FilterData(1) = "TEXT"
    FilterType(2) = 0
    FilterData(2) = "MTEXT"
    FilterType(3) = -4
    FilterData(3) = "or>"

    On Error Resume Next
    ThisDrawing.SelectionSets.Item("FieldsToTable").Delete
    ThisDrawing.SelectionSets.Item("FieldsToTablesorted").Delete
    Set oSset = ThisDrawing.SelectionSets.Add("FieldsToTable")
    Set oSset2 = ThisDrawing.SelectionSets.Add("FieldsToTablesorted")
    On Error GoTo ErrMsg
    oSset.SelectOnScreen FilterType, FilterData
    If oSset.Count <> 0 Then
    
        Dim objTxt As AcadText
        Dim objSSet As AcadSelectionSet
        Dim TxtPnt As Variant
        Dim arTxtPnts() As Variant
        Dim TxtBasePnt(0 To 1) As Double
        Dim iDim As Integer
        iDim = 0
        ReDim Preserve arTxtPnts(oSset.Count - 1, 2)
        For Each objTxt In oSset
            If objTxt.Alignment = acAlignmentLeft Then
                TxtPnt = objTxt.InsertionPoint
            Else
                TxtPnt = objTxt.TextAlignmentPoint
            End If
            TxtBasePnt(0) = TxtPnt(0): TxtBasePnt(1) = TxtPnt(1)
            arTxtPnts(iDim, 0) = TxtPnt(0)
            arTxtPnts(iDim, 1) = TxtPnt(1)
            arTxtPnts(iDim, 2) = objTxt.Handle
            iDim = iDim + 1
        Next
        arTxtPnts = SortArrayByCoords(arTxtPnts)
        Dim arTxtObjs() As AcadText
        'Dim objSortedSSet As AcadSelectionSet
        ReDim arTxtObjs(UBound(arTxtPnts))
        'Set objSortedSSet = ThisDrawing.SelectionSets.Add("SS_Text1")
        For i = 0 To UBound(arTxtPnts)
            Set arTxtObjs(i) = ThisDrawing.HandleToObject(arTxtPnts(i, 2))
        Next
        oSset2.AddItems arTxtObjs
        
        i = oSset2.Count
        ThisDrawing.Utility.GetEntity oTable, basePnt, "Select Table to fill-out:"
        k = oTable.Columns
        If k <> 2 And k <> 5 Then
            Exit Sub
        End If
        j = i  k
        l = 0
        n = 0
        For l = 0 To k - 1
            For m = 3 To j + 2
                celltxtchk = oSset2.Item(n).ObjectName
                If celltxtchk = "AcDbMText" Then
                    Set oMText = oSset2.Item(n)
                    tmpStr = CStr(oMText.ObjectID)
                End If
                If celltxtchk = "AcDbText" Then
                    Set oText = oSset2.Item(n)
                    tmpStr = CStr(oText.ObjectID)
                End If
                tmpStr = "%<AcObjProp Object(%<_ObjId " & tmpStr & _
                ">%).TextString f " & "" & "%bl2" & "" & ">%"
                oTable.SetText m, l, tmpStr
                n = n + 1
                'oTable.Update
            Next
        Next
        
        oSset2.Clear
        oSset2.Delete
        oSset.Clear
        oSset.Delete
        Set oSset2 = Nothing
        Set oSset = Nothing
        Set oSsets = Nothing
        Set oTable = Nothing
        Exit Sub
    End If
    
ErrMsg:
    MsgBox Err.Description
    
    End Sub
Sub SortTextByPos()
Dim objTxt As AcadText
Dim objSSet As AcadSelectionSet
Dim gpCode(0) As Integer: Dim dataVal(0) As Variant
Set objSSet = ThisDrawing.SelectionSets.Add("TxtSet")
gpCode(0) = 0: dataVal(0) = "Text"
ReSelect:
objSSet.SelectOnScreen gpCode, dataVal
If objSSet.Count <> 0 Then
    Dim TxtPnt As Variant
    Dim arTxtPnts() As Variant
    Dim TxtBasePnt(0 To 1) As Double
    Dim iDim As Integer
    iDim = 0
    ReDim Preserve arTxtPnts(objSSet.Count - 1, 2)
    For Each objTxt In objSSet
        If objTxt.Alignment = acAlignmentLeft Then
            TxtPnt = objTxt.InsertionPoint
        Else
            TxtPnt = objTxt.TextAlignmentPoint
        End If
        TxtBasePnt(0) = TxtPnt(0): TxtBasePnt(1) = TxtPnt(1)
        arTxtPnts(iDim, 0) = TxtPnt(0)
        arTxtPnts(iDim, 1) = TxtPnt(1)
        arTxtPnts(iDim, 2) = objTxt.TextString
        iDim = iDim + 1
    Next
    arTxtPnts = SortArrayByCoords(arTxtPnts)
    '<-- Display values for checking -->
    Dim strOP As String
    strOP = strOP & "X Coordinate" & vbTab & vbTab & "Y Coordinate" & _
    vbTab & vbTab & "Text" & vbCrLf
    strOP = strOP & String(22, "-") & vbTab & vbTab & String(22, "-") & _
    vbTab & vbTab & String(5, "-") & vbCrLf
    For i = 0 To UBound(arTxtPnts)
        strOP = strOP & arTxtPnts(i, 0) & vbTab & vbTab & arTxtPnts(i, 1) & _
        vbTab & vbTab & arTxtPnts(i, 2) & vbCrLf
    Next
    MsgBox strOP
    '<-- End display -->
    objSSet.Delete
End If
End Sub

Function SortArrayByCoords(ByVal arSource As Variant)
    Dim i As Integer
    Dim j As Integer
    Dim dblTmpVal(2)
    For i = UBound(arSource) To LBound(arSource) Step -1
       For j = LBound(arSource) + 1 To i
       '<-- Check for the X coordinates first and if they are equel -
       '<-- compare the the Y coordinates -->
         If ( _
                (arSource(j - 1, 0) > arSource(j, 0)) _
                Or ( _
                (arSource(j - 1, 0) = arSource(j, 0)) _
                And _
                (arSource(j - 1, 1) < arSource(j, 1)) _
                ) _
            ) Then
           dblTmpVal(0) = arSource(j - 1, 0)
           dblTmpVal(1) = arSource(j - 1, 1)
           dblTmpVal(2) = arSource(j - 1, 2)
           arSource(j - 1, 0) = arSource(j, 0)
           arSource(j - 1, 1) = arSource(j, 1)
           arSource(j - 1, 2) = arSource(j, 2)
           arSource(j, 0) = dblTmpVal(0)
           arSource(j, 1) = dblTmpVal(1)
           arSource(j, 2) = dblTmpVal(2)
         End If
       Next j
     Next i
  SortArrayByCoords = arSource
End Function

[danderson.71652]

Further Testing, I didn't get MText implemented yet....back to the drawing board

Thanks again,
Dan

Completed code:

removed didnt work

[MikeJarosz]

What Zoomharis has done here is what's called a "Bubble sort" in computer science. It is one of the simplest sorting algorithms to understand, and it has the extra advantage on not requiring additional computer memory. I use it in a number of my programs, one of which sorts by the y-coordinate of a block.

You can Google "bubble sort" and get alot of additional information on it. Some sites will have code you can clip. You will also get info on other algorithms for sorting. It turns out that the bubble sort is the slowest of them all. If you were sorting all IRS tax returns by social security number, you would use a shell sort or a quick sort. These are created by mathematicians and are thousands times faster than the bubble sort.

Why VBA doesn't have some kind of built in sort is a mystery. It would certainly make a lot of our lives easier.

Wish list request??

[danderson.71652]

True, check out this little Gem. All I did was compile the code.
It is a graphical comparison of various sorting methods that you can test.

[zoomharis]

Further Testing, I didn't get MText implemented yet....back to the drawing board

Hi Dan,
I have solved the MText issue in the latest modification. Please have a look at it.

 
Sub SortTextByPos()
On Error Resume Next
Dim objTxt
Dim objSSet As AcadSelectionSet
Dim gpCode(3) As Integer: Dim dataVal(3) As Variant
Set objSSet = ThisDrawing.SelectionSets.Add("TxtSet")
gpCode(0) = -4
dataVal(0) = "<or"
gpCode(1) = 0
dataVal(1) = "TEXT"
gpCode(2) = 0
dataVal(2) = "MTEXT"
gpCode(3) = -4
dataVal(3) = "or>"
objSSet.SelectOnScreen gpCode, dataVal
If objSSet.Count <> 0 Then
	Dim TxtPnt As Variant
	Dim arTxtPnts() As Variant
	Dim TxtBasePnt(0 To 1) As Double
	Dim iDim As Integer
	iDim = 0
	ReDim Preserve arTxtPnts(objSSet.Count - 1, 2)
	For Each objTxt In objSSet
		If TypeOf objTxt Is AcadMText Then
			TxtPnt = objTxt.InsertionPoint
		ElseIf objTxt.Alignment = acAlignmentLeft Then
			TxtPnt = objTxt.InsertionPoint
		Else
			TxtPnt = objTxt.TextAlignmentPoint
		End If
		TxtBasePnt(0) = TxtPnt(0): TxtBasePnt(1) = TxtPnt(1)
		arTxtPnts(iDim, 0) = TxtPnt(0)
		arTxtPnts(iDim, 1) = TxtPnt(1)
		arTxtPnts(iDim, 2) = objTxt.Handle
		iDim = iDim + 1
	Next
	arTxtPnts = SortArrayByCoords(arTxtPnts)
	Dim arTxtObjs() As AcadEntity
	Dim objSortedSSet As AcadSelectionSet
	ReDim arTxtObjs(UBound(arTxtPnts))
	Set objSortedSSet = ThisDrawing.SelectionSets.Add("SS_Text")
	For i = 0 To UBound(arTxtPnts)
		Set arTxtObjs(i) = ThisDrawing.HandleToObject(arTxtPnts(i, 2))
	Next
	objSortedSSet.AddItems arTxtObjs
 
	 '<-- Display values for checking -->
	Dim strOP As String
	For Each objTxt In objSortedSSet
		strOP = strOP & objTxt.TextString & vbCrLf
	Next
	MsgBox strOP
	objSortedSSet.Highlight True
	'<-- End display -->
 
	objSortedSSet.Delete
	objSSet.Delete
End If
If Err.Number <> 0 Then
	MsgBox Err.Description
	Err.Clear
End If
End Sub
Function SortArrayByCoords(ByVal arSource As Variant)
	Dim i As Integer
	Dim j As Integer
	Dim dblTmpVal(2)
	For i = UBound(arSource) To LBound(arSource) Step -1
	 For j = LBound(arSource) + 1 To i
	 '<-- Check for the X coordinates first and if they are equel -
	 '<-- compare the the Y coordinates -->
		 If ( _
				(arSource(j - 1, 0) > arSource(j, 0)) _
				Or ( _
				(arSource(j - 1, 0) = arSource(j, 0)) _
				And _
				(arSource(j - 1, 1) < arSource(j, 1)) _
				) _
			) Then
		 dblTmpVal(0) = arSource(j - 1, 0)
		 dblTmpVal(1) = arSource(j - 1, 1)
		 dblTmpVal(2) = arSource(j - 1, 2)
		 arSource(j - 1, 0) = arSource(j, 0)
		 arSource(j - 1, 1) = arSource(j, 1)
		 arSource(j - 1, 2) = arSource(j, 2)
		 arSource(j, 0) = dblTmpVal(0)
		 arSource(j, 1) = dblTmpVal(1)
		 arSource(j, 2) = dblTmpVal(2)
		 End If
	 Next j
	 Next i
SortArrayByCoords = arSource
End Function

Please incorporate it with your code and give me a feedback if possible.

HTH.
har!s