如何缩放以适合在 PowerPoint 中添加到图像占位符中的图片？

Question

在主布局中，我定义了添加图像的占位符，但我找不到缩放以适合它们的解决方案。图片占位符的原因是可以为不同的布局添加图片，而无需添加确切的位置属性（左、上、宽、高）

我当前的代码如下所示：

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

在下图中，您可以在左侧看到图片是如何添加图像占位符的，在右侧可以看到在适合时应该如何添加。

我找到了执行 "crop to fit" 的代码，但它仅在选中幻灯片时有效：

   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

如何更改代码，在使用上面的代码（子插入图片）添加图像后，图像会被裁剪以适合演示模式？

提前感谢您的帮助！

Answer 1

我们需要做的是获取图片占位符，并将图片分配给这些占位符。您将把您的文件名放在一个数组中，该数组可以容纳与占位符一样多的字符串（我在下面使用了 3 个，因为您说您有 3 个图片占位符）。然后我们将在这些占位符处插入图片并裁剪它们以适合。我借用了 here and here 中使用的概念。所以你的代码将是：

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

谢谢大家的帮助！我设法用以下代码解决了这个问题：

  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

如何缩放以适合在 PowerPoint 中添加到图像占位符中的图片？

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

powerpoint

vba

image

scale