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模板，其中我将Picture占位符添加到必须插入图片的目的地。这种方法的优点是，您可以在PowerPoint中编辑布局，而不必在基本代码中摆弄像素大小。

以下示例位于VBScript中，但可以轻松转移到VBA：

打开PowerPoint模板：

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

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

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

缩放图片以适合占位符的大小：

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

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

2 个答案: