pasting a picture from excel to powerpoint which fits the layout

Question

I have an Excel Picture as Shape and i want to paste it to mny PowerPoint app which has a Special layout which i have already specified.

 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

As its obvious from the code the layout is already set. Now i want the pastedpic1 to fit completely to the layout of the PowerPoint.

What should i do ?

Answer 1

To scale the shape myShape to the size of the slide, use this:

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

Note that depending on the aspect ratio of your shape and slide, stretching may occur. This can be dealt with using the cropping methods.