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

Question

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

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