Sort shapes left to right by selection order (2)

[juanbolas]

Hello everyone,


I'm trying to get a selection of shapes in order from right to left. I found a routine by John Wilson on the board on which I based my code.


The sorting works perfectly when I select Item by item by clicking on the shapes but doesn't respect the "visible order" of shapes if I select them by "lassoing" with my mouse.


Please help me fix this.


Thanks in advance


Sub AlignFlush()
Dim oshpR As ShapeRange
Dim oshp As Shape
Dim L As Long
Dim rayPOS() As Single
Set oshpR = ActiveWindow.Selection.ShapeRange
ReDim rayPOS(1 To oshpR.Count)
'add to array
For L = 1 To oshpR.Count
rayPOS(L) = oshpR(L).Left
Next L
'sort
Call sortray(rayPOS)
'apply
For L = 1 To oshpR.Count
If L = 1 Then
Set oshp = Windows(1).Selection.ShapeRange(1)
PosTop = oshp.Top
PosNext = oshp.Left + oshp.Width
Else
Set oshp = Windows(1).Selection.ShapeRange(L)
oshp.Top = PosTop
oshp.Left = PosNext
PosNext = oshp.Left + oshp.Width
End If
Next L
End Sub

[John Wilson]

Where is the sortRay(rayPos) routine?

[juanbolas]

Sorry, here it is.


Sub sortray(ArrayIn As Variant)
Dim b_Cont As Boolean
Dim lngCount As Long
Dim vSwap As Long
Do
b_Cont = False
For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1
If ArrayIn(lngCount) > ArrayIn(lngCount + 1) Then
vSwap = ArrayIn(lngCount)
ArrayIn(lngCount) = ArrayIn(lngCount + 1)
ArrayIn(lngCount + 1) = vSwap
b_Cont = True
End If
Next lngCount
Loop Until Not b_Cont
End Sub

[juanbolas]

Anyone?

[John Wilson]

Not sure what you mean it works no matter how you select (that's the point of it)

[juanbolas]

What I mean is that when I select the shapes by sliding over them with the mouse (or lassoing them with the mouse) the shapes aren't sorted from left to right reflecting order you select them by.

[juanbolas]

I mean that if you select the shapes by sliding your mouse over them, the sorting seems to be based on the z-order or some other criteria and not the way the shapes are displayed onscreen left to right. If you select the shapes one by one and sort it respects the order you select whereas when you slide over them and intuitively think that the selection is left to right, the select order is not left to right.

[John Wilson]

Just realized the code you have is different to mine here.

Try


Sub AlignFlush()
Dim oshpR As ShapeRange
Dim oshp As Shape
Dim L As Long
Dim rayPOS() As Shape
Dim PosTop As Long
Dim PosNext As Long
Set oshpR = ActiveWindow.Selection.ShapeRange


ReDim rayPOS(1 To oshpR.Count)
'add to array
For L = 1 To oshpR.Count
Set rayPOS(L) = oshpR(L)
Next L
'sort
Call sortray(rayPOS)
'apply
For L = 1 To UBound(rayPOS)
If L = 1 Then
Set oshp = rayPOS(L)
PosTop = oshp.Top
PosNext = oshp.Left + oshp.Width
Else
Set oshp = rayPOS(L)
oshp.Top = PosTop
oshp.Left = PosNext
PosNext = oshp.Left + oshp.Width
End If
Next L
End Sub
Sub sortray(ArrayIn As Variant)
Dim b_Cont As Boolean
Dim lngCount As Long
Dim vSwap As Shape
Do
b_Cont = False
For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1
If ArrayIn(lngCount).Left > ArrayIn(lngCount + 1).Left Then
Set vSwap = ArrayIn(lngCount)
Set ArrayIn(lngCount) = ArrayIn(lngCount + 1)
Set ArrayIn(lngCount + 1) = vSwap
b_Cont = True
End If
Next lngCount
Loop Until Not b_Cont
End Sub

[juanbolas]

Perfect! Thanks John

[juanbolas]

@johnwilson

I had no problem adapting the code to work vertically. The original aligns left, my modification aligns from top.

Now I was trying to get it to align right but the shapes end up all over the place. Then the idea was to adapt flush to bottom.

Thanks in advance

Thanks in advance


Global Const txDrawAreaLeft As Integer = 60
Global Const txDrawAreaWidth As Integer = 840

Sub AlignRight()
Dim oshpR As ShapeRange
Dim oshp As Shape
Dim L As Long
Dim rayPOS() As Shape
Dim PosTop As Long
Dim PosNext As Long
Set oshpR = ActiveWindow.Selection.ShapeRange
ReDim rayPOS(1 To oshpR.Count)
'add to array
For L = 1 To oshpR.Count
Set rayPOS(L) = oshpR(L)
Next L
'sort
Call sortray(rayPOS)
'apply
For L = 1 To UBound(rayPOS)
If L = 1 Then
Set oshp = rayPOS(L)
PosTop = oshp.Top
PosNext = (txDrawAreaLeft + txDrawAreaWidth) - oshp.Width
Else
Set oshp = rayPOS(L)
oshp.Top = PosTop
oshp.Left = PosNext
PosNext = (txDrawAreaLeft + txDrawAreaWidth) - oshp.Width
End If
Next L
End Sub