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

'https://stackoverflow.com/questions/41803095/paste-a-range-from-excel-into-certain-slide-of-powerpoint-template-using-vba
'Slide Count https://stackoverflow.com/questions/45391119/powerpoint-slide-count-variable-in-vba
'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

2 个答案: