Search code examples
vbaimagepowerpointscale

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

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.

Comparison

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!

Solution

  • 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