将图片从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. 打开幻灯片模板：

   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")