爲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宏

回答

相關問題