Question

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

有时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次。如有必要，请更改此设置以留出更多时间。

PowerPoint冻结和代码连续

1 个答案: