Sort selected items
Hi @jplujan could you try to run this code ? Of course the code it's very poor, but it's working.
Sub Bloques()
Dim Entity As Object
Dim ATT As Variant
Dim ATT_VALUE() As Variant
Dim BL_INS_X() As Variant
A = 1
For Each Entity In ThisDrawing.ModelSpace
If Entity.ObjectName = "AcDbBlockReference" Then
If Entity.Name = "BL_01" Then
If Entity.HasAttributes = True Then
ReDim Preserve ATT_VALUE(A)
ReDim Preserve BL_INS_X(A)
ATT = Entity.GetAttributes
ATT_VALUE(A) = Val(ATT(0).TextString)
BL_INS = Entity.InsertionPoint
BL_INS_X(A) = BL_INS(0)
A = A + 1
End If
End If
End If
Next
SortArray ATT_VALUE()
SortArray BL_INS_X()
'A = 1
For Each Entity In ThisDrawing.ModelSpace
If Entity.ObjectName = "AcDbBlockReference" Then
If Entity.Name = "BL_01" Then
BL_INS = Entity.InsertionPoint
For QQ = LBound(BL_INS_X) To UBound(BL_INS_X)
If BL_INS(0) = BL_INS_X(QQ) Then
If Entity.HasAttributes = True Then
ATT = Entity.GetAttributes
ATT(0).TextString = ATT_VALUE(QQ)
End If
End If
Next
End If
End If
Next
ThisDrawing.Regen acAllViewports
End Sub
Function SortArray(ArrayToSort() As Variant)
Dim x As Long, y As Long
Dim TempTxt1 As Variant
Dim TempTxt2 As Variant
For x = LBound(ArrayToSort) To UBound(ArrayToSort)
For y = x To UBound(ArrayToSort)
If (ArrayToSort(y)) < (ArrayToSort(x)) Then
TempTxt1 = ArrayToSort(x)
TempTxt2 = ArrayToSort(y)
ArrayToSort(x) = TempTxt2
ArrayToSort(y) = TempTxt1
End If
Next y
Next x
End Function
What the code is doing is:
Search all blocks with Name "BL_01", Get attributes, and X insertion Point.
Make an ascendant sort by Attribute Value and X value from lower to higher.
Change attributes to all blocks, starting from the one which has lowest X insertion point value.
Let us know.
Regards
Hi @jplujan after some test I been able to adjust the code also for 2 lines
Here below the example as picture.
here the code
Function SortArray(ArrayToSort() As Variant)
Dim x As Long, y As Long
Dim TempTxt1 As Variant
Dim TempTxt2 As Variant
For x = LBound(ArrayToSort) To UBound(ArrayToSort)
For y = x To UBound(ArrayToSort)
If (ArrayToSort(y)) < (ArrayToSort(x)) Then
TempTxt1 = ArrayToSort(x)
TempTxt2 = ArrayToSort(y)
ArrayToSort(x) = TempTxt2
ArrayToSort(y) = TempTxt1
End If
Next y
Next x
End Function
Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' SampleUsage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub
Sub Bloques_NEW()
Dim sset As AcadSelectionSet
Set sset = ThisDrawing.SelectionSets.Add("TestSet4")
Dim Entity As Object
Dim ATT As Variant
Dim ATT_VALUE() As Variant
Dim BL_INS_X_Y() As Variant
Dim filterType As Variant
Dim filterData As Variant
'Dim p1(0 To 2) As Double
'Dim p2(0 To 2) As Double
Dim grpCode(0) As Integer
grpCode(0) = 2
filterType = grpCode
Dim grpValue(0) As Variant
grpValue(0) = "BL_01"
filterData = grpValue
sset.Select acSelectionSetAll, , , filterType, filterData
'Debug.Print "Entities: " & Str(sset.Count)
Q = sset.Count
If Q > 0 Then
ReDim ATT_VALUE(Q)
ReDim BL_INS_X_Y(Q, 1)
A = 0
For Each Entity In sset
If Entity.HasAttributes = True Then
ATT = Entity.GetAttributes
ATT_VALUE(A) = Val(ATT(0).TextString)
BL_INS = Entity.InsertionPoint
BL_INS_X_Y(A, 0) = BL_INS(0)
BL_INS_X_Y(A, 1) = BL_INS(1)
A = A + 1
End If
Next
SortArray ATT_VALUE()
Call QuickSortArray(BL_INS_X_Y, , , 0)
For Each Entity In sset
BL_INS = Entity.InsertionPoint
For QQ = LBound(BL_INS_X_Y) To UBound(BL_INS_X_Y)
If BL_INS(0) = BL_INS_X_Y(QQ, 0) Then
If BL_INS(1) = BL_INS_X_Y(QQ, 1) Then
If Entity.HasAttributes = True Then
ATT = Entity.GetAttributes
ATT(0).TextString = ATT_VALUE(QQ)
End If
End If
End If
Next
Next
End If
ThisDrawing.Regen acAllViewports
sset.Delete
End Sub
As you can see the order of attribute will be the same from lower to highest, but it's shifted by row.
Of course code could be optimized, but it's only a test, a staring point.
I'll try to test if it's possible to order consecutive by row... I'll keep you informed.
