使用 VBA 从 Excel 创建多个 PPT

Question

我想使用 VBA 创建多个 PPT 文件。

考虑到这个案例，PPT申请已经打开
当我运行宏时，它应该创建一个新的 PPT 文件，但我的宏会在打开的文件上附加幻灯片。

如何创建一个单独的 PPT 文件并执行其他操作？

下面是部分代码。

Dim newPowerPoint As Object 'PowerPoint.Application  '
Dim activeSlide As Object 'PowerPoint.Slide
Dim sht As Worksheet 

On Error Resume Next
Set newPowerPoint = CreateObject("PowerPoint.Application")
'If newPowerPoint Is Nothing Then
    'Set newPowerPoint = New PowerPoint.Application
'End If

If newPowerPoint.Presentations.Count = 0 Then
    newPowerPoint.Presentations.Add
End If

'Show the PowerPoint
newPowerPoint.Visible = True

For Each sht In ActiveWorkbook.Sheets  
    newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
    newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
    Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)

    activeSlide.Shapes(1).Delete
    activeSlide.Shapes(1).Delete
    Range("A1:T32").Select
    Selection.Copy
    activeSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select

Answer 1

您不想创建一个新的 PPT 应用程序，您需要的是一个新的 PPT 演示文稿，然后向其中添加幻灯片。最简单的方法是为演示文稿添加一个变量（即Dim PPPres As Powerpoint.Presentation），然后将新幻灯片添加到该演示文稿

编辑：包括我用于初始化 PPT 演示文稿的代码版本：

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide

'Open PPT if not running, otherwise select active instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
    'Open PowerPoint
    Set PPApp = CreateObject("PowerPoint.Application")
    PPApp.Visible = True
End If
On Error GoTo ErrHandler

'Generate new Presentation and slide for graphic creation
Set PPPres = PPApp.Presentations.Add
Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
PPApp.ActiveWindow.ViewType = ppViewSlide
PPPres.PageSetup.SlideSize = ppSlideSizeOnScreen
PPApp.ActiveWindow.WindowState = ppWindowMaximized

Answer 2

*' 使用 vba

将 excel 转换为 ppt 的代码

子ExcelToPowerPointv2() 变暗为范围将 PowerPointApp 调暗为对象将 myPresentation 调暗为对象将 mySlide 调暗为对象将 myShape 调暗为对象将 ArrayOne 调暗为变体

'Create an Instance of PowerPoint
On Error Resume Next

'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors
Err.Clear

'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If

On Error GoTo 0

'Optimize Code
Application.ScreenUpdating = False

Array_Sheet = Array("S1", "S2")

'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Dim sld As Slides

'inside for loop, copy the elements of the sheet & paste it on PPT
For n = 1 To 0 Step -1 '2 sheets less 1, because of the array index 0
Set rng = ActiveWorkbook.Sheets(Array_Sheet(n)).Range("B2:B10")
rng.Copy

Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
mySlide.Shapes.PasteSpecial DataType:=2  '2 = ppPasteEnhancedMetafile

Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 152
Next n

Dim PPslide As PowerPoint.Slide
'Dim sld As Slide
SlidesCount = myPresentation.Slides.Count

For SlideNumber = 1 To SlidesCount
Set rng = ActiveWorkbook.Sheets(Array_Sheet(SlideNumber - 1)).Range("D2:D10")
rng.Copy
'MsgBox (SlideNumber)
Set PPslide = myPresentation.Slides(SlideNumber)
PPslide.Shapes.PasteSpecial DataType:=2
Application.CutCopyMode = False
'mySlide(SlideNumber).Shapes.PasteSpecial DataType:=2
Set myShape = PPslide.Shapes(PPslide.Shapes.Count)
'Set position:
myShape.Left = 66
myShape.Top = 300
Next SlideNumber

Dim myTextbox As PowerPoint.Shape
For SlideNumber = 1 To SlidesCount
'MsgBox (SlideNumber)
With myPresentation.Slides(SlideNumber)
Set myTextbox = .Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, Left:=500, Top:=250, Width:=400, Height:=100)
myTextbox.TextFrame.TextRange.Text = "Hello I am a text box"
End With
Next SlideNumber

End Sub

'
'Slide Count 
'http://www.java2s.com/Code/VBA-Excel-Access-Word/PowerPoint/UsetheAddTextboxMethodtoaddatextboxtotheeighthslideandassigntexttoit.htm
'https://www.thespreadsheetguru.com/blog/2014/3/17/copy-paste-an-excel-range-into-powerpoint-with-vba
'https://docs.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addtextbox
'https://img.chandoo.org/vba/Automatically_Create_PowerPoint_From_Excel_VBA_Code.txt*

使用 VBA 从 Excel 创建多个 PPT

Create multiple PPT from Excel using VBA

excel

powerpoint

vba