Warning: Long post
Here's the code that I finally came up with. It probably will look like a joke to you masters out there, but I'm pretty much happy with the end result. The corners act a bit strange sometimes (the top, left, right and bottom are much more reliable).
Form code:
[vba]
Option Explicit
Public myChoice As String
Private Sub btn_Cancel_Click()
Call btn_Reset_Click
Unload Me
End Sub
Private Sub btn_OK_Click()
Dim myTop As Single
Dim myLeft As Single
'Dim myAlign As String
If Not myChoice = "" Then
If Not tb_gapChoice.Value = "" Then
'MsgBox ("myChoice: " & myChoice & vbLf & "myTop: " & myTop & vbLf & "myLeft: " & myLeft)
myMagnetize.magnetChoice = myChoice
myMagnetize.magGapChoice = CSng(tb_gapChoice.Value)
End If
End If
Unload Me
End Sub
Private Sub btn_Reset_Click()
tb_gapChoice.Value = 0
myChoice = ""
End Sub
Private Sub lbl_bottom_Click()
ob_bottom.Value = True
End Sub
Private Sub lbl_top_Click()
ob_top.Value = True
End Sub
Private Sub ob_bottom_Click()
myChoice = "bottom"
End Sub
Private Sub ob_bottomleft_Click()
myChoice = "bottomleft"
End Sub
Private Sub ob_bottomright_Click()
myChoice = "bottomright"
End Sub
Private Sub ob_left_Click()
myChoice = "left"
End Sub
Private Sub ob_right_Click()
myChoice = "right"
End Sub
Private Sub ob_top_Click()
myChoice = "top"
End Sub
Private Sub ob_topleft_Click()
myChoice = "topleft"
End Sub
Private Sub ob_topright_Click()
myChoice = "topright"
End Sub
Private Sub UserForm_Initialize()
Me.Top = 100
Me.Left = 100
End Sub
[/vba]
And here is the main code. I called the module "myMagnetize":
[vba]
Option Explicit
Public magnetChoice As String
Public magGapChoice As Single
Sub Magnetize()
Dim mySlide As Long
Dim shp As Shape
Dim newLeft As Single
Dim newTop As Single
Dim newWidth As Single
Dim newHeight As Single
Dim newShp As ShapeRange
Dim num As Long
Dim i As Long
'Many thanks to M.O.S. Master (Joost Verdaasdonk) and Killian from
'the VBA Express forum (http://vbaexpress.com/forum/) for
'helping me with this project.
mySlide = ActiveWindow.View.Slide.SlideIndex
frm_Magnet.Show
'MsgBox ("magnetChoice: " & magnetChoice)
Select Case magnetChoice
'MsoAlignCmd: msoAlignBottoms, msoAlignCenters, msoAlignLefts, msoAlignMiddles, msoAlignRights, msoAlignTops
'ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, False
'use TRUE if you want to align relative to slide
Case "left"
Call MoveShapesLeft
Case "topleft"
Call MoveShapesTopLeft
Case "top"
Call MoveShapesTop
Case "topright"
Call MoveShapesTopRight
Case "right"
Call MoveShapesRight
Case "bottomright"
Call MoveShapesBottomRight
Case "bottom"
Call MoveShapesBottom
Case "bottomleft"
Call MoveShapesBottomLeft
End Select
End Sub
Sub MoveShapesLeft()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColLeft colTemp
End If
End With
'reposition shapes in new order
For i = 1 To colTemp.Count
If i = 1 Then
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Left = (myMagnetize.magGapChoice * 72) + colTemp(i - 1).Left + colTemp(i - 1).Width
End If
Next
End Sub
Sub MoveShapesRight()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColRight colTemp
End If
End With
'reposition shapes in new order
For i = colTemp.Count To 1 Step -1
If i = colTemp.Count Then
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Left = colTemp(i + 1).Left - (myMagnetize.magGapChoice * 72) - colTemp(i).Width
End If
Next
End Sub
Sub MoveShapesTop()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColTop colTemp
End If
End With
'reposition shapes in new order
For i = 1 To colTemp.Count
If i = 1 Then
colTemp(i).Top = colTemp(i).Top
Else
colTemp(i).Top = colTemp(i - 1).Top + colTemp(i - 1).Height + (myMagnetize.magGapChoice * 72)
End If
Next
End Sub
Sub MoveShapesBottom()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColBottom colTemp
End If
End With
'reposition shapes in new order
For i = colTemp.Count To 1 Step -1
If i = colTemp.Count Then
colTemp(i).Top = colTemp(i).Top
Else
colTemp(i).Top = colTemp(i + 1).Top - (myMagnetize.magGapChoice * 72) - colTemp(i).Height
End If
Next
End Sub
Sub MoveShapesTopLeft()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColTopLeft colTemp
End If
End With
'reposition shapes in new order
For i = 1 To colTemp.Count
If i = 1 Then
colTemp(i).Top = colTemp(i).Top
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Top = colTemp(i - 1).Top + (myMagnetize.magGapChoice * 72) + colTemp(i - 1).Height
colTemp(i).Left = colTemp(i - 1).Left + (myMagnetize.magGapChoice * 72) + colTemp(i - 1).Width
End If
Next
End Sub
Sub MoveShapesBottomLeft()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColBottomLeft colTemp
End If
End With
'reposition shapes in new order
For i = 1 To colTemp.Count
If i = 1 Then
colTemp(i).Top = colTemp(i).Top
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Top = colTemp(i - 1).Top - (myMagnetize.magGapChoice * 72) - colTemp(i - 1).Height
colTemp(i).Left = colTemp(i - 1).Left + (myMagnetize.magGapChoice * 72) + colTemp(i - 1).Width
End If
Next
End Sub
Sub MoveShapesTopRight()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColTopRight colTemp
End If
End With
'reposition shapes in new order
For i = colTemp.Count To 1 Step -1
If i = colTemp.Count Then
colTemp(i).Top = colTemp(i).Top
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Top = colTemp(i + 1).Top + (myMagnetize.magGapChoice * 72) + colTemp(i).Height
colTemp(i).Left = colTemp(i + 1).Left - (myMagnetize.magGapChoice * 72) - colTemp(i).Width
End If
Next
End Sub
Sub MoveShapesBottomRight()
Dim colTemp As New Collection
Dim shp As Shape
Dim i As Long
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
'add all selected shapes to new collection
For Each shp In .ShapeRange
colTemp.Add shp
Next shp
'sort the collection
SortColBottomRight colTemp
End If
End With
'reposition shapes in new order
For i = colTemp.Count To 1 Step -1
If i = colTemp.Count Then
colTemp(i).Top = colTemp(i).Top
colTemp(i).Left = colTemp(i).Left
Else
colTemp(i).Top = colTemp(i + 1).Top - (myMagnetize.magGapChoice * 72) - colTemp(i).Height
colTemp(i).Left = colTemp(i + 1).Left - (myMagnetize.magGapChoice * 72) - colTemp(i).Width
End If
Next
End Sub
Sub SortColLeft(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Left > col(j).Left Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
Next j
Next i
End Sub
Sub SortColRight(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Left + col(i).Width > col(j).Left + col(j).Width Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
Next j
Next i
End Sub
Sub SortColTop(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Top > col(j).Top Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
Next j
Next i
End Sub
Sub SortColBottom(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Top + col(i).Height > col(j).Top + col(j).Height Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
Next j
Next i
End Sub
Sub SortColBottomRight(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Left + col(i).Width > col(j).Left + col(j).Width Then
If col(i).Top + col(i).Height > col(j).Top + col(j).Height Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
End If
Next j
Next i
End Sub
Sub SortColTopRight(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 1 To col.Count - 1
For j = i + 1 To col.Count
If col(i).Left + col(i).Width > col(j).Left + col(j).Width Then
If col(i).Top + col(i).Height < col(j).Top + col(j).Height Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
End If
Next j
Next i
End Sub
Sub SortColBottomLeft(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 2 To col.Count
For j = i + 1 To col.Count
If col(i).Left + col(i).Height > col(j).Left + col(j).Height Then
If col(i).Top < col(j).Top Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
End If
Next j
Next i
End Sub
Sub SortColTopLeft(col As Collection)
' bubble sort collection
' derived from http://www.dicks-blog.com/archives/2...-a-collection/
' by Dick Kusleika
Dim vItm As Shape
Dim i As Long, j As Long
Dim vTemp As Shape
For i = 2 To col.Count
For j = i + 1 To col.Count
If col(i).Left < col(j).Left Then
If col(i).Top < col(j).Top Then
Set vTemp = col(j)
col.Remove j
col.Add vTemp, , i
End If
End If
Next j
Next i
End Sub
[/vba]