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