Dynamic Image Adjustment

[Damffer]

Hello everyone, how are you?
I hope everything goes good.

A couple of weeks ago, i open a thread with a problem: adjust the same size to all the images in an active presentation withouth textboxes.
The code worked, but now i have other problem. The images that i paste in each slide, has different dimensions what makes difficult the correct visualization of the slide. Now, i would to know if it's possible adjust all the images in the active slide dynamiclly.

For example, i have 4 images in the active slide. These images have the same high size and cannot exceed 13 centimeters high. I want them to be distributed horizontally with a small space between them and without leaving the slide. If the sum of the widths is higher that the slide width, reduce all images. Like this:

28605

The same situation when i paste 3,2 or 1 images. Ever the max images per slide will be 4.

I hope i have explained well.
It would be great if you can help me.

Thanks.

[John Wilson]

You could start with this and play with it!


Sub fixPic()
Dim rayPic() As Shape
Dim osld As Slide
Dim opic As Shape
Dim L As Long
ReDim rayPic(1 To 1)
Set osld = ActiveWindow.Selection.SlideRange(1)
For Each opic In osld.Shapes
If isPIC(opic) Then
opic.Height = 100
Set rayPic(UBound(rayPic)) = opic
ReDim Preserve rayPic(1 To UBound(rayPic) + 1)
End If
Next opic
rayPic(1).Left = 10
rayPic(1).Top = 100
rayPic(1).Select
For L = 2 To UBound(rayPic) - 1
rayPic(L).Left = rayPic(L - 1).Width + rayPic(L - 1).Left + 10
rayPic(L).Top = 100
rayPic(L).Select False
Next L
With ActiveWindow.Selection.ShapeRange.Group
.LockAspectRatio = True
.Width = ActivePresentation.PageSetup.SlideWidth - 20
.Left = 10
.Ungroup
End With
End Sub


Function isPIC(opic As Shape) As Boolean
If opic.Type = msoPicture Then isPIC = True
If opic.Type = msoPlaceholder Then
If opic.PlaceholderFormat.ContainedType = msoPicture Then isPIC = True
End If
End Function