如何在 Powerpoint 中使用 VBA 调整第二张图片的大小？答案

【问题标题】：How do I resize a second picture with VBA in Powerpoint?如何在 Powerpoint 中使用 VBA 调整第二张图片的大小？
【发布时间】：2020-02-10 14:31:45
【问题描述】：

我设法通过 VBA 从 Excel 获取图片到 Powerpoint。这种方法效果很好。但是，我想重新定位并调整第二张图片的大小。

你能帮帮我吗？

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

【问题讨论】：

旁注：pptApp代表powerpoint应用，所以不需要Set Graphic = GetObject(, "Powerpoint.Application")。只需使用pptApp。
未经测试，但我会尝试按索引引用形状...它应该是该幻灯片上的最后一个形状，因此您可以使用Shapes.Count。

标签： excel vba powerpoint

【解决方案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

【讨论】：