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

我设法通过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

---

正如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

---

旁注：

pptApp

表示powerpoint应用程序，因此不需要

Set Graphic=GetObject（，“powerpoint.application”）

。只需使用

pptApp

。未经测试，但我会尝试按索引引用形状。。。它应该是该幻灯片上的最后一个形状，这样您就可以使用

形状。Count

。