将一张图片从 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

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

我该怎么办？

Answer 1

要将形状 myShape 缩放到幻灯片的大小，请使用：

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

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

Answer 2

我遇到了类似的问题，但采用了另一种方法： 我创建了一个 PowerPoint 模板，我在其中将图片占位符添加到必须插入图片的目的地。这种方法的优点是，您可以在 PowerPoint 中编辑布局，而不必在基本代码中调整像素大小。

以下示例是在 VBScript 中，但可以轻松转换为 VBA：

1. 打开PowerPoint模板：

   Dim powerPoint, presentation
   Set powerPoint = CreateObject("PowerPoint.Application")    
   Set presentation = powerPoint.Presentations.open("C:\template.pptx")
   

2. 选择占位符，然后粘贴图片：

   Dim slide, view, image, placeholder
   Set view = m_presentation.Windows(1).View
   Set slide = m_presentation.Slides(slideId)
   view.GotoSlide(slide.SlideIndex)
   Set placeholder = slide.Shapes(shapeName)
   placeholder.Select()
   view.Paste()
   slide.Application.CommandBars.ExecuteMso("PictureFitCrop")
   

3. 缩放图片以适应占位符的大小：

   slide.Application.CommandBars.ExecuteMso("PictureFitCrop")