PowerPoint Photo Albums

The Photo Album feature in PowerPoint 2002 onwards is a quick way to insert a large number of photographs in a PowerPoint presentation.

Pre 2007 the "Pictures" were actually filled shapes and couldn't be cropped etc like real pictures. In 2007 this has been fixed.

Even so the layout of the album is still limited, this code allows you more flexibilty and it's virtually instant.

IT IS ONLY FOR ALBUMS WITH ONE PIC PER SLIDE AND NO CAPTION!

Thanks to Sarah for pointing out that captions kill the code!

Always work on a copy of your presentation!

To use copy the code into a module in the VBE (If you're lost already please see "How to use vba in a presentation" ) then adjust any one picture to the size, position etc you require adding borders, shadows etc if you wish. Select this picture and run the code.

All Done!

If you do not have version 2007 you should change the line

If oshp.Type = msoPicture Then
TO
If oshp.Fill.Type = msoFillPicture Then

NB If you have 2002/3 and real pictures (not inserted with Photo Album) use the 2007 code

The code:

'Copy from here -----------------
Sub photoalbum()
Dim osld As Slide
Dim oshp As Shape
Dim sngLeft As Single
Dim sngWidth As Single
Dim sngHeight As Single
Dim sngTop As Single
Dim sngrot As Single

On Error GoTo errhandler
If ActiveWindow.Selection.Type = ppSelectionNone Then Exit Sub

Set oshp = ActiveWindow.Selection.ShapeRange(1)

With oshp
sngTop = .Top
sngLeft = .Left
sngWidth = .Width
sngHeight = .Height
sngrot = .Rotation
.PickUp
End With

For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.Type = msoPicture Then 'change this line to line below for pre 2007
'if oshp.Fill.Type = msoFillPicture Then

With oshp
.Top = sngTop
.Left = sngLeft
.Width = sngWidth
.Height = sngHeight
.Rotation = sngrot
.Apply
End With
End If
Next oshp
Next osld
Exit Sub
errhandler:
MsgBox "Did you select a shape?"
End Sub'
To here -----------------------

The code below sets all the pictures to the same height keeping the original aspect ratio and centres the picture

'Copy from here -----------------
Sub centrepic()
Dim i As Integer
Dim osld As Slide
Dim opic As ShapeRange
For Each osld In ActivePresentation.Slides
For i = 1 To osld.Shapes.Count
If osld.Shapes(i).Type = msoPicture Then
'use line below for photo albums before 2007 and delete line above
'if osld.shapes(i).fill.type=msoFillPicture then
Set opic = osld.Shapes.Range(i)
opic.LockAspectRatio = True
opic.Height = 200'change to suit
opic.Align msoAlignMiddles, msoTrue
opic.Align msoAlignCenters, msoTrue
End If
Next i
Next osld
End Sub
To here -----------------------

Back to the Index Page

POWERPOINT BLOG

Articles on your favourite sport

Free Microsoft PowerPoint Advice, help and tutorials, Template Links
This website is sponsored by Technology Trish Ltd
© Technology Trish 2007
Registered in England and Wales No.5780175
PowerPoint® is a registered trademark of the Microsoft Corporation