Как изменить размер второй картинки с помощью VBA в Powerpoint?

Question

Мне удалось получить изображение из Excel в Powerpoint через VBA. Этот метод работает отлично. Тем не менее, я хотел бы изменить положение и изменить размер второй картинки.

Не могли бы вы мне помочь?

Sub ExceltoPP()

Dim pptPres As Presentation     
Dim strPath As String           
Dim strPPTX As String           
Dim pptApp As Object



    strPath = "D:\"
    strPPTX = "Test.pptx"       

    Set pptApp = New PowerPoint.Application

    pptCopy = strPath & strPPTX

    pptApp.Presentations.Open Filename:=pptCopy, untitled:=msoTrue

    Set pptPres = pptApp.ActivePresentation   

    Sheets("NEW").Range("Table").CopyPicture xlScreen, xlPicture
    pptPres.Slides(2).Select
    pptPres.Slides(2).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    Set Graphic = GetObject(, "Powerpoint.Application")
    With Graphic.ActiveWindow.Selection.ShapeRange
      .Left = 0.39 * 72
      .Top = 2 * 72
      .Width = 5 * 72
      .Height = 2 * 72
    End With

До этой части она работает отлично. Тем не менее, когда я пытаюсь добавить второе изображение, Powerpoint добавляет изображение, но изменение положения и изменение размера не работает.

Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
    pptPres.Slides(2).Select
    pptPres.Slides(2).Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

    Set Graphic2 = GetObject(, "Powerpoint.Application")
    With Graphic2.ActiveWindow.Selection.ShapeRange
      .Left = 0.39 * 72
      .Top = 5 * 72
      .Width = 5 * 72
      .Height = 2 * 72
    End With


    pptPres.SaveAs strPath & Range("company") & ".pptx"  
    pptPres.Close      
    pptApp.Quit
    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub

Answer 1

Как предлагает BigBen, вы можете ссылаться на нужную фигуру по индексу. Однако нет необходимости вызывать GetObject. Попробуйте ...

Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
With pptPres.Slides(2)
    .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
    With .Shapes(.Shapes.Count) 'refers to last pasted shape
        .Left = 0.39 * 72
        .Top = 5 * 72
        .Width = 5 * 72
        .Height = 2 * 72
    End With
End With

Ваш код может быть переписан следующим образом ...

'Force the explicit declaration of variables
Option Explicit

Sub ExceltoPP()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim strPath As String
    Dim strPPTX As String
    Dim pptCopy As String

    strPath = "D:\"
    strPPTX = "Test.pptx"

    pptCopy = strPath & strPPTX

    Set pptApp = New PowerPoint.Application

    Set pptPres = pptApp.Presentations.Open(Filename:=pptCopy, untitled:=msoTrue)

    Sheets("NEW").Range("Table").CopyPicture xlScreen, xlPicture
    With pptPres.Slides(2)
        .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
        With .Shapes(.Shapes.Count) 'refers to last pasted shape
            .Left = 0.39 * 72
            .Top = 2 * 72
            .Width = 5 * 72
            .Height = 2 * 72
        End With
    End With

    Sheets("NEW").Range("A1:M14").CopyPicture xlScreen, xlPicture
    With pptPres.Slides(2)
        .Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
        With .Shapes(.Shapes.Count) 'refers to last pasted shape
            .Left = 0.39 * 72
            .Top = 5 * 72
            .Width = 5 * 72
            .Height = 2 * 72
        End With
    End With

    pptPres.SaveAs strPath & Range("company").Value & ".pptx"
    pptPres.Close
    pptApp.Quit

    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub