为PowerPoint优化VBA宏

我从VBA编辑器创建了一个简报，当我创建单个幻灯片时，它效果很好。但是，当我尝试一次创建它们时，PowerPoint崩溃。我通过在每张幻灯片的末尾设置Application.CutCopyMode=False来清除记忆，并有Application.Wait持续7秒。为PowerPoint优化VBA宏

我的幻灯片将会是大约25张幻灯片，它已经崩溃过去了幻灯片7.通常它会在格式化时崩溃。我在每个Macro使用的3个基本布局和幻灯片8和9中添加了它的崩溃位置。

我使用的第一个宏从上一个演示文稿复制幻灯片，并粘贴到新的PPT。
第二个粘贴表格
第三个粘贴表格，图表和图片（仅滑动图片，否则此类型的幻灯片仅粘贴表格和图表）。

代码：

Sub CreateNewPresentation() 

    Application.ScreenUpdating = False 
    Application.EnableEvents = False 

    Dim ppApp As PowerPoint.Application 
    Dim ppPres As PowerPoint.Presentation 
    Dim slidesCount As Long 

    If ppApp Is Nothing Then 
    Set ppApp = New PowerPoint.Application 
    End If 

    Set ppPres = ppApp.Presentations.Add 
    ppPres.SaveAs "FileName" 

    ppApp.Visible = True 
    slidesCount = ppPres.Slides.Count 

    Call create_Slide1(slidesCount, ppPres, ppApp) 
    slidesCount = ppPres.Slides.Count 
    Application.CutCopyMode = False 

Call create_Slide2(slidesCount, ppPres) 
    slidesCount = ppPres.Slides.Count 
    Application.CutCopyMode = False 

Call create_Slide3(slidesCount, ppPres) 
    slidesCount = ppPres.Slides.Count 
    Application.CutCopyMode = False 
    ppPres.Save 
    ppPres.Close 

Call create_Slide8(slidesCount, ppPres) 
    slidesCount = ppPres.Slides.Count 
    Application.CutCopyMode = False 

Call create_Slide9(slidesCount, ppPres) 
    slidesCount = ppPres.Slides.Count 
    Application.CutCopyMode = False 

    Application.ScreenUpdating = True 
    Application.EnableEvents = True 

End Sub 

sub Create_Slide1(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application) 
    Dim myFile As String 
    Dim ppSlide As PowerPoint.Slide 
    Dim objPres As PowerPoint.Presentation 
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank) 
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper 

    myFile:"File name and path....." 
    Set objPres=ppt.Presentations.Open(myFile) 
    objPres.Slides(1).Copy 
    ppPrez.Slides.Paste Index:=sldNum+1 
    objPres.Close 
    ppPrez. Slides(sldNum+2).Delete 
End Sub 
Sub create_Slide2(sldNum As Long, ppPrez As PowerPoint.Presentation) 
    Dim ppSlide As PowerPoint.Slide 
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank) 
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper 
    ppSlide.Select 
    ThisWorkbook.Worksheets("Sheet2").Activate 
    ActiveSheet.Range(Cells(3, 2), Cells(27, 11)).Copy 
    ppSlide.Shapes.Paste.Select 
    With ppSlide.Shapes(1) 
     .Top = ppPrez.PageSetup.SlideHeight/20 
     .Left = ppPrez.PageSetup.SlideWidth/20 
     .Height = 17 * (ppPrez.PageSetup.SlideHeight)/20 
     .Width = 9 * (ppPrez.PageSetup.SlideWidth/10) 
    End With 

End Sub 
sub create_Slide3(sldNum As Long, ppPrez As PowerPoint.Presentation) 
    Dim ppSlide As PowerPoint.Slide 
    Dim ppTextBox As PowerPoint.Shape 
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank) 
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper 
    ppSlide.Select 

    Set ppTextBox = ppSlide.Shapes.AddTextbox(_ 
    msoTextOrientationHorizontal, 0, 15, ppPrez.PageSetup.SlideWidth, 60) 
    With ppTextBox.TextFrame 
     .TextRange.Text = "Slide3" 
     .TextRange.ParagraphFormat.Alignment = ppAlignCenter 
     .TextRange.Font.Size = 20 
     .TextRange.Font.Name = "Calibri" 
     .VerticalAnchor = msoAnchorMiddle 
    End With 
    ThisWorkbook.Sheets("Sheet3").Activate 
    ActiveSheet.Range(Cells(17, 10), Cells(19, 19)).Copy 
    ppSlide.Shapes.Paste.Select 
    With ppSlide.Shapes(2) 
     .Width = (6/10) * ppPrez.PageSetup.SlideWidth 
     .Left = (1/40) * ppPrez.PageSetup.SlideWidth 
     .Top = (5/8) * ppPrez.PageSetup.SlideHeight 
    End With 
    Sheets("Sheet3").Shapes("Shape1").CopyPicture 
    ppSlide.Shapes.Paste 
    ppSlide.Shapes(4).Height = 850 
    ppSlide.Shapes(4).Width = 275 
    ppSlide.Shapes(4).Left = (6.2/10) * ppPrez.PageSetup.SlideWidth 
    ppSlide.Shapes(4).Top = (1/10) * ppPrez.PageSetup.SlideHeight 
End sub 

sub create_Slide8(sldNum As Long, ppPrez As PowerPoint.Presentation) 
    Dim ppSlide As PowerPoint.Slide 
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank) 
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper 
    ppSlide.Select 

    ThisWorkbook.Sheets("roll").Activate 
    ActiveSheet.ChartObjects("35").Activate 
    ActiveChart.ChartArea.Copy 
    ppSlide.Shapes.Paste.Select 
    With ppSlide.Shapes(1) 
    .Left = 1 * (ppPrez.PageSetup.SlideWidth/20) 
    .Height = _ 
     ppPrez.PageSetup.SlideHeight/2 
    .Width = _ 
     9 * (ppPrez.PageSetup.SlideWidth/10) 
    .Top = 0 
End With 

    Application.Wait (Now + TimeValue("0:00:03")) 
    Application.CutCopyMode = False 
    MsgBox ("done") 

    ActiveSheet.ChartObjects("40").Activate 
    ActiveChart.ChartArea.Copy 
    ppSlide.Shapes.Paste.Select 
    With ppSlide.Shapes(2) 
     .Left = 1 * (ppPrez.PageSetup.SlideWidth/20) 
     .Height = _ 
      ppPrez.PageSetup.SlideHeight/2 
     .Width = _ 
      9 * (ppPrez.PageSetup.SlideWidth/10) 
     .Top = _ 
      ppPrez.PageSetup.SlideHeight/2 
    End With 

    Application.Wait (Now + TimeValue("0:00:07")) 
    MsgBox ("done") 
End Sub 

sub create_Slide9(sldNum As Long, ppPrez As PowerPoint.Presentation, ppt As PowerPoint.Application) 

    Dim ppSlide As PowerPoint.Slide 
    Dim objPres As PowerPoint.Presentation 
    Set ppSlide = ppPrez.Slides.Add(sldNum + 1, ppLayoutBlank) 
    ppPrez.PageSetup.SlideSize = ppSlideSizeLetterPaper 
    ppSlide.Select 

    myFile = "File Path....same as above" 
    Set objPres = ppt.Presentations.Open(myFile) 
    objPres.Slides(8).Copy 
    ppPrez.Slides.Paste Index:=sldNum + 1 'sometimes it fails here too because of a paste issue (Either vba doesn't like method or no where to paste too) 
    objPres.Close 
    ppPrez.Slides(sldNum + 2).Delete 
    MsgBox ("done") 
    Application.Wait (Now + TimeValue("0:00:07")) 
End Sub

来源

2017-08-07 Jack Armstrong

得到我们可以看到的任何代码？ – NickSlash

@NickSlash我已经添加了我使用的代码的基本布局。 create_Slide＃宏只是简单地将一个图表，表格和片段复制到带有格式的新幻灯片中。 –

目前无法对其进行测试，但您可以尝试减慢执行速度（在create_slide调用之间进行sleep/doevents类型的操作）或调整代码，以便创建表单的宏返回指示完成并准备好执行下一个命令的操作。 – NickSlash

我不能肯定，但我认为，消息框被阻塞。执行被停止，直到它被处理，所以不会给你的代码时间来恢复。

下面的代码应该可以工作，但我不太喜欢它。它是我可以做的最好的，无需修改其他一些功能代码。

希望你可以看到代码背后的想法是什么，并且可以改进它。理想情况下，它会使用一个循环，并在您的CreateNewPresentation子中，而不是递归函数。你可能只是Sleep 100更换提示消息框在你的代码，而不是用我的代码（复制睡眠宣言你的模块后）

PowerPoint不具有ScreenUpdating的交易类型和一些命令做需要一段时间才能完成。在每张幻灯片之间使用睡眠可能有所帮助，但可能不会在您的create_slideN宏中的某些函数调用之间加入一些Sleep可能是值得的。我从来没有使Powerpoint自动化，所以不知道它是如何工作的。

Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) 

Public CreationIndex As Integer 
Dim ppApp As PowerPoint.Application 
Dim ppPres As PowerPoint.Presentation 
Dim slideCount As Integer 

Sub CreateNewPresentation() 

    Application.ScreenUpdating = False 
    Application.EnableEvents = False 

    If ppApp Is Nothing Then 
     Set ppApp = New PowerPoint.Application 
    End If 

    Set ppPres = ppApp.Presentations.Add 
    ppPres.SaveAs "FileName" 

    ppApp.Visible = True 

    CreationIndex = 1 

    Create CreationIndex ' start the ball rolling... 

End Sub 

Sub Create(i As Integer) 
slidesCount = ppPres.Slides.Count 
Select Case i 
Case 1 
    Call Create_Slide1(slidesCount, ppPres, ppApp) 
Case 2 
    Call create_Slide2(slidesCount, ppPres) 
Case 3 
    Call create_Slide3(slidesCount, ppPres) 
Case Else 
    MsgBox "Complete or Broken...", vbOKOnly 
    Exit Sub 
End Select 

Application.CutCopyMode = False 

Sleep 200 ' wait for a bit... 

CreationIndex = CreationIndex + 1 
Create CreationIndex 

End Sub

来源

2017-08-08 23:01:08 NickSlash

为PowerPoint优化VBA宏

回答

相关问题