With PowerPoint, I have created several templates made of groups of shapes that I would copy to create nice image galleries in a Word document.

My idea is to automate the following process:

1. select a shape
2. shape format > shape fill > picture > from a file
3. picture format > crop > fill

by a macro that would do:

1. select all shapes in the selected slide
2. chose a folder and select pictures
3. fill each shape with the pictures
4. crop all the pictures in the shapes to fill the shapes

I have a macro that fill a specific shape on a specific slide with an image thanks to the filedialog. Thanks to commandbars I can do the PictureFillCrop.

Sub FillPictureAndFillCrop()
Dim strFilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> 0 Then
            strFilePath = .SelectedItems(1)
            With ActivePresentation.Slides(1).Shapes(1).Fill
                .Visible = msoTrue
                .UserPicture strFilePath
            End With
            ActivePresentation.Slides(1).Shapes(1).Select
            CommandBars.ExecuteMso ("PictureFillCrop")
        End If
    End With
End Sub

I still need to extend this macro to all the shapes of the selected slide with each pictures I have selected. I have a previous macro with which I can select multiple pictures and add one picture per newly created slide. I would like to adapt it to the macro above.

Sub AddOneImagePerNewSlide()
    Dim ImgI As Long, tmpDIAPO As Slide
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Add "Images", "*.png, *.gif; *.jpg; *.jpeg", 1
        If .Show = -1 Then
            For ImgI = 1 To .SelectedItems.Count
                Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutBlank)
                tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
                    LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, _
                    Left:=0, Top:=0, _
                    Width:=-1, Height:=-1
            Next
        End If
    End With
End Sub

I think it would be a mix of the 2 above macro would work. Is it doable?

CodePudding user response：

Yes, it is doable.

With this macro you will not need to select the Shapes.

Sub ShapePictureFitCrop(Shape As Shape)
    Dim Width As Double, Height As Double
    
    With Shape
        Width = .Width
        Height = .Height
        .ScaleWidth 1, msoFalse
        .ScaleHeight 1, msoFalse
        .PictureFormat.CropRight = .Width * Width / 100
        .PictureFormat.CropBottom = .Height * Height / 100
    End With
End Sub

CodePudding user response：

@Clemleb

To loop through all the shapes on each slide, you'd do something like this:

    Option Explicit
    
    Sub EachShape()
    
    Dim oSh As Shape
    Dim oSl As Slide
    
    For Each oSl In ActivePresentation.Slides
    For Each oSh In oSl.Shapes
        ' You might add code here to
        ' ensure that it's the right shape type
        ' For example, exclude shapes with text
        If oSh.HasTextFrame And oSh.TextFrame.HasText Then
            ' Leave it alone
        Else
            Call DoSomethingWith(oSh)
        End If
    Next    ' Shape
    Next    ' Slide
    
    End Sub
    
    Sub DoSomethingWith(oSh As Shape)
        ' you could call TinMan's example here
        ShapePictureFitCrop (oSh)
        ' then do other things with the shape
    End Sub

Sub ShapePictureFitCrop(Shape As Shape)
    Dim Width As Double, Height As Double
    
    With Shape
        Width = .Width
        Height = .Height
        .ScaleWidth 1, msoFalse
        .ScaleHeight 1, msoFalse
        .PictureFormat.CropRight = .Width * Width / 100
        .PictureFormat.CropBottom = .Height * Height / 100
    End With
End Sub