PowerPoint用のVBAマクロの最適化

Question

私はVBAエディタからパワーポイントを作成しています。個々のスライドを作成すると素晴らしい結果が得られます。しかし、一度にすべて作成しようとすると、PowerPointがクラッシュします。私は各スライドの最後にApplication.CutCopyMode=Falseを設定してメモリをクリアし、Application.Waitを7秒間持っています。

私のパワーポイントは約25個のスライドとなり、スライド7より前にクラッシュしています。通常、フォーマットするとクラッシュします。私が使用する各マクロの3つの基本レイアウトを追加し、クラッシュする場所の8と9をスライドさせます。

1. 私が使用している最初のマクロは、最後のプレゼンテーションのスライドと新しい電源ポイントへの ペーストをコピーします。
2. 第2のペーストテーブル
3. 第3のペーストテーブル、図表、写真（写真付きスライドのみ、このタイプのスライドは表と図表だけを貼り付ける）。

コード：

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 

Answer 1

私は確かではないんだけど、私はそのメッセージボックスがブロックしていると思います。実行は処理されるまで停止されますので、コードを回復する時間は与えないでください。

次のコードは機能するはずですが、私は本当にそれが好きではありません。その最高の私はあなたの他の機能するコードのいくつかを変更せずに行うことができます。

コードの背後にあるアイデアが何であるかを見て、改善することをお勧めします。 理想的には、ループを使用し、再帰関数の代わりにCreateNewPresentationサブの内部にあることが理想的です。 あなたが潜在的にちょうど（あなたのモジュールにスリープ宣言をコピーした後）私のコードを使うSleep 100であなたのコード内でメッセージボックスを交換しませんでした

PowerPointがScreenUpdatingタイプの契約を持っていないと、一部のコマンドが完了するまでにしばらく時間がかかりません。各スライド間でスリープを使用すると役立つかもしれませんが、そうでないかもしれません。 create_slideNマクロ内のいくつかの関数呼び出しの間にいくつかのスリープを置く価値があります。私は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