通过VBA将Excel表格复制到PowerPoint并保存

Question

我正在尝试批量生成一系列PowerPoint演示文稿。我的幻灯片将包含两个元素，包括从Excel创建和复制。我正在使用Office 2010。

第一个元素是SmartArt图形，它可以顺利完成。第二个是我希望复制为Table对象（而不是链接图像）的几个单元格。用“形状”浪费了几个小时之后，我找到了这个，但是在粘贴后我无法操纵它的高度和宽度。

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

然后，当我尝试使用以下内容保存演示文稿时，我意识到只保存了SmartArt;即使在粘贴后发生了，也不会保存粘贴的表格。

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
PPPres.SaveAs saveName, ppSaveAsDefault
PPPres.Close

更奇怪的是，我发现当我在粘贴和保存之间添加一个用于调试的msgbox命令时，表格被正确保存。但是，我正在尝试批量生成这些文件，并且无法坐下来关闭每个消息框。

我的问题： 1.粘贴后如何更改表格的高度/宽度/对齐方式？ 2.如何保存包含表格的文件？

已编辑，我当前的代码

Sub copyAllToPpt()

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim PPName, xlName As String

xlName = ActiveWorkbook.Name
Dim saveName As String

Workbooks(xlName).Activate
Dim y As Integer
y = ActiveCell.Row
saveName = ActiveSheet.Cells(y, "B").Value & "-" & ActiveSheet.Cells(y, "A").Value & " Stats"

Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Add
PPName = PPPres.Name

PPApp.ActiveWindow.ViewType = ppViewSlide

Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)

createSmartArtGraphicThenCopy

PPSlide.Shapes.Paste.Select

PPApp.ActiveWindow.Selection.ShapeRange.Height = 288
PPApp.ActiveWindow.Selection.ShapeRange.Width = 641
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
PPApp.ActiveWindow.Selection.Unselect
'Macro is working as expected up to here

Workbooks(xlName).Activate

createTable
'Table is copied in subroutine

PPApp.Activate

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
'Application.Wait (Now + TimeValue("0:00:05"))
'Tried the Wait() to no avail.

DoEvents: DoEvents: DoEvents

PPApp.ActivePresentation.SaveAs saveName, ppSaveAsDefault
PPApp.ActivePresentation.Close

End Sub

Answer 1

当我从PPT中运行它时，这是有效的;你需要通过添加对PPT应用程序对象的引用来适应它：

Dim oSh As Object
Dim oSl As Object
Dim x As Long

x = 1 ' or whatever slide you want to work with

Set oSl = ActivePresentation.Slides(x)

CommandBars.ExecuteMso ("PasteSourceFormatting")
DoEvents: DoEvents: DoEvents

Set oSh = oSl.Shapes(oSl.Shapes.Count)

oSh.Left = 0
' etc

如果没有DoEvents语句，它将失败，其方式与保存问题失败的方式完全相同。除非你给PPT几个周期来处理新粘贴的形状，否则它认为它不存在。