使用文件夹中选定的图片填充每个形状并裁剪它们以填充 - VBA - Powerpoint 或 Word

Question

我使用 PowerPoint 创建了几个由形状组组成的模板，我将复制这些模板以在 Word 文档中创建漂亮的图像库。

我的想法是自动化以下过程：

1. 选择形状
2. 形状格式>形状填充>图片>>从文件
3. 图片格式>作物> 填充

通过宏进行

1. ：选择所选幻灯片中的所有形状
2. 选择一个文件夹并选择图片
3. 用图片填充每个形状
4. 裁剪形状中的所有图片以填充形状

我有一个宏，可以在特定的位置上填充特定的形状借助文件对话框，可以使用图像进行滑动。感谢命令栏，我可以进行图片填充裁剪。

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

我仍然需要将此宏扩展到所选幻灯片的所有形状以及我选择的每张图片。 我以前有一个宏，可以使用它选择多张图片并为​​每个新创建的幻灯片添加一张图片。 我想将其适应上面的宏。

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

我认为上面两个宏的混合会起作用。 可行吗？

Answer 1

是的，这是可行的。

使用此宏，您将不需要选择形状。

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

Answer 2

@Clemleb

要循环浏览每张幻灯片上的所有形状，您需要执行以下操作：

    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