VBA in PowerPoint for placement of images on slides

Hi,

I am new to posting and to VBA but here goes...

I create multiple PPT presentations each week, some with up to 70 images. I use PowerPoint 2010 and Image Importer Wizard to add 4 images/slide. I then manually swap some images between slides or delete some, leaving between 1-4 images per slide. These are embedded images.

I am trying to create a macro that will set the remaining images on a fixed location on the slide.  I currently manually set their positions from the top left corner of the slide using the Format Picture box as follows:

Image 1 is Horizontal position .9, vertical 1.08

Image 2 is 5.02, 1.08,

Image 3 is .95, 4.17

and Image 4 is 5.02, 4.17

I want the macro to run through all the slides, the order of the 4 images on the slides are not essential, although if I understand how the macro chooses image 1, image 2... I can position them to have the desired layout while I re-position them.

The closest think I have found lines the pictures up vertically with a fixed gap between them.

Option Explicit

Private Const MaxDouble = 1.79769313486231E+308

Private Type ShapePOINT

  x As Single

  y As Single

End Type

Private Type ShapeRECT

  TL As ShapePOINT

  BR As ShapePOINT

End Type

Sub DistributeShapes()

  Dim ShapeArea As ShapeRECT

  Dim Sh As Shape

  Dim i As Long, P As Long

  Dim ToDo As New Collection, Done As New Collection

  Dim Space As Single

  'Define the space between

  Space = InchToPoints(0.25)

  'Try to get the selected shapes

  On Error GoTo NoShapes

  For Each Sh In ActiveWindow.Selection.ShapeRange

    ToDo.Add Sh

  Next

  If ToDo.Count < 2 Then

NoShapes:

    MsgBox "Select at min. 2 shapes"

    Exit Sub

  End If

  On Error GoTo 0

  'Calculate the area

  ShapeArea = GetShapeArea(ToDo)

  'Find the closest Shape

  Dim Distance As Double, Min As Double

  Dim x As Double, y As Double

  Dim MinSh As Shape, NextSh As Shape

  Do While ToDo.Count > 0

    'Find the closest shape to the top left

    Min = MaxDouble

    i = 0

    For Each Sh In ToDo

      i = i + 1

      x = Sh.Left + Sh.Width / 2

      y = Sh.Top + Sh.Height / 2

      Distance = Sqr((x - ShapeArea.TL.x) ^ 2 + (y - ShapeArea.TL.y) ^ 2)

      If Distance < Min Then

        Min = Distance

        Set MinSh = Sh

        P = i

      End If

    Next

    If Done.Count = 0 Then

      'Move to the top left

      MinSh.Left = ShapeArea.TL.x

      MinSh.Top = ShapeArea.TL.y

    Else

      'Look upwards and find the next shape that is in our way

      Set NextSh = Nothing

      For Each Sh In Done

        If MinSh.Left < Sh.Left + Sh.Width And MinSh.Left + MinSh.Width > Sh.Left Then

          If NextSh Is Nothing Then

            Set NextSh = Sh

          Else

            'Choose the nearest

            If NextSh.Top + NextSh.Height < Sh.Top + Sh.Height Then

              Set NextSh = Sh

            End If

          End If

        End If

      Next

      'Move up

      If NextSh Is Nothing Then

        MinSh.Top = ShapeArea.TL.y

      Else

        MinSh.Top = NextSh.Top + NextSh.Height + Space

      End If

      'Look to the left and find the next shape that is in our way

      Set NextSh = Nothing

      For Each Sh In Done

        If MinSh.Top < Sh.Top + Sh.Height And MinSh.Top + MinSh.Height > Sh.Top Then

          If NextSh Is Nothing Then

            Set NextSh = Sh

          Else

            'Choose the nearest

            If NextSh.Left + NextSh.Width < Sh.Left + Sh.Width Then

              Set NextSh = Sh

            End If

          End If

        End If

      Next

      'Move Left

      If NextSh Is Nothing Then

        MinSh.Left = ShapeArea.TL.x

      Else

        MinSh.Left = NextSh.Left + NextSh.Width + Space

      End If

    End If

    'This one is done

    Done.Add MinSh

    ToDo.Remove P

  Loop

End Sub

Private Function InchToPoints(ByVal inch As Single) As Single

  InchToPoints = inch * 72

End Function

Private Function GetShapeRECT(S As Shape) As ShapeRECT

  'Return the coordinates of a shape

  With GetShapeRECT

    .TL.x = S.Left

    .TL.y = S.Top

    .BR.x = S.Left + S.Width

    .BR.y = S.Top + S.Height

  End With

End Function

Private Function GetShapeArea(ByVal SR As Object) As ShapeRECT

  'Return the max. area of all shapes in SR (Sr = ShapeRange or Collection)

  Dim i As Long

  Dim Temp As ShapeRECT

  If SR.Count < 1 Then Exit Function

  GetShapeArea = GetShapeRECT(SR(1))

  With GetShapeArea

    For i = 2 To SR.Count

      Temp = GetShapeRECT(SR(i))

      If .TL.x > Temp.TL.x Then .TL.x = Temp.TL.x

      If .TL.y > Temp.TL.y Then .TL.y = Temp.TL.y

      If .BR.x < Temp.BR.x Then .BR.x = Temp.BR.x

      If .BR.y < Temp.BR.y Then .BR.y = Temp.BR.y

    Next

  End With

End Function

Thank you in advance for any help, or for even pointing me in another direction where I might find success.