vba - 将图片从 excel 粘贴到适合布局的 powerpoint

Question

我有一个 Excel 图片作为形状，我想将它粘贴到我已经指定的特殊布局的 mny PowerPoint 应用程序中。

 Sub ExcelShapePowerpoint()
  Dim PowerPointApp As Object
  Dim myPresentation As Object
  Dim mySlide As Object
  Dim myShape As Object

 Dim pastedPic1 As Shape

Set DestinationSheet1 = Workbooks("myExcelFile.xlsm").Sheets("myExcelSheet")
Set pastedPic1 = DestinationSheet1.Shapes(10)
     On Error Resume Next

Set PowerPointApp = GetObject(class:="PowerPoint.Application")
  If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
  If Err.Number = 429 Then
    MsgBox "PowerPoint could not be found, aborting."
    Exit Sub
  End If

 On Error GoTo 0

  Application.ScreenUpdating = False

  Set myPresentation = PowerPointApp.Presentations.Add
 Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
   With myPresentation.PageSetup

.SlideWidth = 961

.SlideHeight = 540

End With

  pastedPic1.Copy


   mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
  myShape.Left = -15

  myShape.Top = 11

    PowerPointApp.Visible = True
    PowerPointApp.Activate

     Application.CutCopyMode = False

 End Sub

从代码中可以明显看出，布局已经设置好了。现在我希望 pasteedpic1 完全适合 PowerPoint 的布局。

我应该怎么办 ？

Answer 1

缩放形状我的形状 到幻灯片的大小，使用这个:

With myShape
  .Top = 0
  .Left = 0
  .Width = ActivePresentation.PageSetup.SlideWidth
  .Height = ActivePresentation.PageSetup.SlideHeight
End With

请注意，根据形状和幻灯片的纵横比，可能会发生拉伸(stretch)。这可以使用裁剪方法来处理。