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

Question

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

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

PPApp.CommandBars.ExecuteMso ("PasteSourceFormatting")

然后，当我尝试使用以下方法保存演示文稿时，我意识到只保存了 SmartArt；即使在粘贴之后执行了 saveAs 命令，粘贴的表格也不会保存。

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 几个循环来处理新粘贴的形状，否则它认为它不存在。