PowerPoint 冻结，代码继续

Question

我有 VBA 代码，可以创建图表并将它们作为 PDF 保存在 PowerPoint 演示文稿中。

有时 PowerPoint 应用程序会冻结，并且代码会继续创建下一个文件。最后，代码关闭了应用程序，所以一些文件没有保存。

Sub ChartToPresentation(ByVal blz As String)
' Uses Early Binding to the PowerPoint Object Model
' Set a VBE reference to Microsoft PowerPoint Object Library
    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim sht As Worksheet
    Dim CurrentSheet As Worksheet
    Dim cht As ChartObject
    Dim i As Integer
    Dim oSh As Object
    Dim spkname As String
    Dim quote As Double
    Dim pptLayout As CustomLayout
    Dim nutzerzahl As Integer
    Dim bilanzsumme As Double
    Dim verbandname As String
    Dim filepath As String

    i = 1
    spkname = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
        Find(blz, LookIn:=xlValues).Offset(0, 1)
    quote = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
        Find(blz, LookIn:=xlValues).Offset(0, 5)
    nutzerzahl = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
        Find(blz, LookIn:=xlValues).Offset(0, 4)
    bilanzsumme = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
        Find(blz, LookIn:=xlValues).Offset(0, 2)
    verbandname = ActiveWorkbook.Sheets("Ranking (alle)").Range("A:A"). _
        Find(blz, LookIn:=xlValues).Offset(0, 3)

    Set PPApp = CreateObject("Powerpoint.Application")
    Set PPPres = PPApp.Presentations.Open("........")
    Set pptLayout = PPPres.SlideMaster.CustomLayouts(3)
    filepath = PPPres.Path & "\Export\" & "\" & blz & "_" & spkname & "_" & _
        Format(DateAdd("M", -1, Now), "MMMM") & " " & Year(Now) & ".pdf"
    For Each sht In ActiveWorkbook.Worksheets
        For Each cht In sht.ChartObjects
            cht.Activate
            i = i + 1
            ' Reference existing instance of PowerPoint
            PPApp.ActiveWindow.ViewType = ppViewSlide
            ' Reference active slide
            Set PPSlide = PPPres.Slides.AddSlide(i, pptLayout)
            ' Copy chart as a picture
            ActiveChart.ChartArea.Copy
            ' Paste chart
            Set oSh = PPSlide.Shapes.PasteSpecial(ppPasteBitmap, msoFalse)
            With oSh
                .LockAspectRatio = msoFalse
                .Left = (6.51 * 28.34646)
                .Top = (3.15 * 28.34646)
                .Height = (12.04 * 28.34646)
                .Width = (17.97 * 28.34646)
            End With
            With PPSlide.Shapes("Inhaltsplatzhalter 4")
            If i = 2 Then
                .TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
                    vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & vbCrLf & _
                    sht.Name & vbCrLf & "(App - Downloads, kum.)" & vbCrLf & _
                    vbCrLf & "Quote(User/Mrd. BS):" & vbNewLine & _
                    Round(quote, 0) & " User pro Mrd. BS"
                .TextFrame.TextRange.Font.Size = 12
                .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
                .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
                .TextFrame.TextRange.Font.Name = "Sparkasse rg"
            ElseIf i = 3 Then
                .TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
                    vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & vbCrLf & _
                    vbCrLf & vbCrLf & vbCrLf & sht.Name & vbCrLf & _
                    "N = " & ActiveWorkbook.Sheets(sht.Name).Range("A:A") _
                    .Cells.SpecialCells(xlCellTypeConstants).Count - 1
                .TextFrame.TextRange.Font.Size = 12
                .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
                .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
                .TextFrame.TextRange.Font.Name = "Sparkasse rg"
            ElseIf i = 4 Then
                .TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
                        vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & _
                        vbCrLf & "Bilanzsumme: " & Round(bilanzsumme, 1) _
                        & " Mrd." & vbCrLf & vbCrLf & vbCrLf & sht.Name _
                        & vbCrLf & "N = " & ActiveWorkbook.Sheets(sht.Name) _
                        .Range("A:A").Cells. _
                        SpecialCells(xlCellTypeConstants).Count - 1
                .TextFrame.TextRange.Font.Size = 12
                .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
                .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
                .TextFrame.TextRange.Font.Name = "Sparkasse rg"
            Else
                .TextFrame.TextRange.Text = vbCrLf & spkname & vbCrLf & _
                        vbCrLf & "BLZ: " & blz & vbCrLf & vbCrLf & _
                        vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Ranking (" _
                        & verbandname & ")" & vbCrLf & "N = " & _
                        ActiveWorkbook.Sheets(sht.Name).Range("A:A"). _
                        Cells.SpecialCells(xlCellTypeConstants).Count - 1
                .TextFrame.TextRange.Font.Size = 12
                .TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
                .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
                .TextFrame.TextRange.Font.Name = "Sparkasse rg"
            End If
            End With
        Next cht
    Next sht
    With PPPres.Slides(1).Shapes("Rechteck 3")
        .TextFrame.TextRange.Text = vbCrLf & vbCrLf & spkname & vbCrLf _
                        & vbCrLf & "Bankleitzahl: " & blz
        .TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
        .TextFrame.TextRange.Font.Size = 16
        .TextFrame.TextRange.Font.Bold = msoCTrue
    End With
    PPPres.ExportAsFixedFormat PPPres.Path & "\Export\" & "\" & blz & _
                        "_" & spkname & "_" & Format(DateAdd("M", -1, _
                        Now), "MMMM") & " " & Year(Now) & ".pdf", _
                        ppFixedFormatTypePDF, ppFixedFormatIntentPrint
    PPPres.Close
    PPApp.Quit
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
End Sub

Answer 1

除了按照 ashleedawg 和 Profex 的建议尝试提高代码效率并添加 DoEvents 之外，还可以尝试添加循环以帮助确保为创建形状提供足够的时间。尝试替换...

    ' Paste chart
    Set oSh = PPSlide.Shapes.PasteSpecial(ppPasteBitmap, msoFalse)

与

    ' Paste chart
    PPSlide.Shapes.PasteSpecial ppPasteBitmap, msoFalse

    On Error Resume Next
    counter = 0
    Do
        DoEvents
        counter = counter + 1
        Set oSh = PPSlide.Shapes(PPSlide.Shapes.Count)
        If Not oSh Is Nothing Then Exit Do
        If counter > 100 Then Exit Do
    Loop
    On Error GoTo 0

请注意，counter 应与您的其他变量一起在代码开头声明。您可以将其声明为类型Long。另外，请注意，目前它最多循环 100 个循环。如有必要，更改此设置以留出更多时间。