Powerpoint 2003 Replace Image

So Powerpoint 2007 has a nice easy right-click option on an image to choose a new image file and keep everything else unchanged (especially animations). Unfortunately, those still using 2003 are pretty much SOL, at least without using VBA.

So here's some VBA for doing this. You'll have to set up a UI, and pass in the shape to use (get selected shape using: ActiveWindow.Selection.ShapeRange(1) ). So basically the code looks at the passed in shape, creates a new shape, copies all the properties from the old shape to the new, and deletes the old shape.

Function UpdateImage_BuildNewFromFile(TheImage As PowerPoint.Shape, ImageFile As String) As Boolean

' Create a new shape and add the image (unlinked) from TheImage, copy attributes and size, position, etc...

UpdateImage_BuildNewFromFile = True

On Error Resume Next

'On Error GoTo PROC_ERR

If TheImage Is Nothing Then GoTo PROC_ERR_BELOW

If ImageFile = "" Then GoTo PROC_ERR_BELOW

If Not TypeOf TheImage.Parent Is Slide Then GoTo PROC_ERR_BELOW

Dim TheSlide As PowerPoint.Slide

Set TheSlide = TheImage.Parent

Dim NewShape As PowerPoint.Shape

Set NewShape = TheSlide.Shapes.AddPicture(ImageFile, msoFalse, msoTrue, 100, 100)

With NewShape

With .PictureFormat

.CropBottom = TheImage.PictureFormat.CropBottom

.CropLeft = TheImage.PictureFormat.CropLeft

.CropRight = TheImage.PictureFormat.CropRight

.CropTop = TheImage.PictureFormat.CropTop

.Brightness = TheImage.PictureFormat.Brightness

.ColorType = TheImage.PictureFormat.ColorType

.Contrast = TheImage.PictureFormat.Contrast

.TransparentBackground = TheImage.PictureFormat.TransparentBackground

End With

.Left = TheImage.Left

.Top = TheImage.Top

.Width = TheImage.Width

.Height = TheImage.Height

SetZPosition NewShape, TheImage.ZOrderPosition

With .AnimationSettings

.AdvanceMode = TheImage.AnimationSettings.AdvanceMode

.AdvanceTime = TheImage.AnimationSettings.AdvanceTime

.AfterEffect = TheImage.AnimationSettings.AfterEffect

.Animate = TheImage.AnimationSettings.Animate

.AnimateBackground = TheImage.AnimationSettings.AnimateBackground

.AnimateTextInReverse = TheImage.AnimationSettings.AnimateTextInReverse

.AnimationOrder = TheImage.AnimationSettings.AnimationOrder

.ChartUnitEffect = TheImage.AnimationSettings.ChartUnitEffect

.DimColor = TheImage.AnimationSettings.DimColor

.EntryEffect = TheImage.AnimationSettings.EntryEffect

With .PlaySettings

.ActionVerb = TheImage.AnimationSettings.PlaySettings.ActionVerb

.HideWhileNotPlaying = TheImage.AnimationSettings.PlaySettings.HideWhileNotPlaying

.LoopUntilStopped = TheImage.AnimationSettings.PlaySettings.LoopUntilStopped

.PauseAnimation = TheImage.AnimationSettings.PlaySettings.PauseAnimation

.PlayOnEntry = TheImage.AnimationSettings.PlaySettings.PlayOnEntry

.RewindMovie = TheImage.AnimationSettings.PlaySettings.RewindMovie

.StopAfterSlides = TheImage.AnimationSettings.PlaySettings.StopAfterSlides

End With

.TextLevelEffect = TheImage.AnimationSettings.TextLevelEffect

.TextUnitEffect = TheImage.AnimationSettings.TextUnitEffect

End With

End With

PROC_EXIT:

If Not TheImage Is Nothing Then TheImage.Delete

On Error GoTo 0

Exit Function

PROC_ERR:

MsgBox Err.Description

UpdateImage_BuildNewFromFile = False

GoTo PROC_EXIT

PROC_ERR_BELOW:

UpdateImage_BuildNewFromFile = False

GoTo PROC_EXIT

End Function