How to scale to fit pictures, that are added into image placeholders in powerpoint? - vba

Question

In the master layout I defined the placeholders where the images are added, but I can't find a solution to scale to fit them. The reason for the image placeholders is that the pictures can be added for different layouts without adding the exact location properties (Left, Top, Width, Height)
My current code looks like this:
Sub InsertPictures
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
End Sub
In the picture below you can see on the left side how the picture is added with a image placeholder and on the right side how it should be added, when its fitted.
I found a code which does the "crop to fit", but it only works when the slide is selected:
Sub cropFit()
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.View.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub
How do I have to change the code that directly after adding the images with the code above (Sub Insert Pictures), the images are cropped to fit in the presentation mode?
Thanks for your help in advance!

Answer 1

What we need to do is get the Picture Placeholders, and assign pictures to those placeholders. You will put your file names in an array that can hold as many strings as placeholders ( I used 3 below because you say you have 3 picture placeholders). Then we will insert the pictures at those placeholders and crop them to fit. I borrowed concepts used here and here. So your code would be:
Sub InsertPictures()
Dim FileNames(1 To 3) As String, Shps As Shapes, i As Integer
Set Shps = ActivePresentation.Slides(1).Shapes
FileNames(1) = "U:\xyz\EAP.png"
FileNames(2) = "U:\xyz\DAP_01.png"
' Filenames(3) = "Blah Blah Blah"
i = 1
For Each Shp In Shps.Placeholders
' You only need to work on Picture place holders
If Shp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With Shp
' Now add the Picture
Set s = Shps.AddPicture(FileNames(i), msoTrue, msoTrue, _
.Left, .Top, .Width, .Height)
' Insert DoEvents here specially for big files, or network files
' DoEvents halts macro momentarily until the
' system finishes what it's doing which is loading the picture file
DoEvents
s.Select
CommandBars.ExecuteMso ("PictureFitCrop")
i = i + 1
End With
End If
If (i > UBound(FileNames)) Then Exit For
If (FileNames(i) = "") Then Exit For
Next Shp
End Sub

Answer 2

Thank you guys for your help! I managed to solve this problem with the following code:
Sub CropToFit()
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\EAP.png", _LinkToFile:=msoTrue
ActivePresentation.Slides(1).Shapes.AddPicture FileName:="U:\xyz\DAP_01.png", LinkToFile:=msoTrue, _
ActivePresentation.SlideShowWindow.view.Exit
Do Events
Dim osld As Slide
Dim oshp As Shape
On Error Resume Next
Set osld = ActiveWindow.view.Slide
If Not osld Is Nothing Then
For Each oshp In osld.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderPicture Then
oshp.Select
CommandBars.ExecuteMso ("PictureFitCrop")
End If 'picture placeholder
End If 'placehoder
Next oshp
End If ' Slide selected
End Sub