VBA 代码使 PPT 应用程序崩溃 - 原因不明

Question

我对以下代码有疑问。发生的情况是我的 PPT 应用程序在运行代码时崩溃了。它并不总是发生，它发生在代码的不同部分。

我尝试了application.wait-method，但它不起作用。

非常感谢您的帮助，因为我已经为此工作了好几天 -.-。提前致谢。

Option Explicit
Public myfilename As String

Sub filepicker()
Dim i As Variant
    MsgBox ("In the following dialog please choose the current file")
    Dim myfilenamepicker As FileDialog
    Set myfilenamepicker = Application.FileDialog(msoFileDialogFilePicker)
    myfilenamepicker.InitialFileName = "C:\Users\Michael\Desktop\Test PPT"
    myfilenamepicker.Show
    If myfilenamepicker.SelectedItems.Count <> 0 Then
        myfilename = myfilenamepicker.SelectedItems(1)
    End If
End Sub


Sub Saveas_PPT_and_PDF()

Dim PP As PowerPoint.Presentation
Dim sh As Variant
Dim company, strPOTX, strPfad, pptVorlage, newpath, newpathpdf As String
Dim Cell As Range
Dim pptApp As Object

    Call filepicker
    Application.ScreenUpdating = False

    ' set the dropdown from which the company Is Selected
    Set DropDown.ws_company = Tabelle2

    ' the company is the value selected in the dropdown, stored in "C2"
    company = DropDown.ws_company.Range("C2").Value

    On Error Resume Next
        Set pptApp = GetObject(, "PowerPoint.Application")
        On Error Resume Next

        If pptApp Is Nothing Then
            Set pptApp = CreateObject("PowerPoint.Application")
        End If
    On Error GoTo 0

    'loop through the companies in the dropdown menu
    For Each Cell In DropDown.ws_company.Range(DropDown.ws_company.Cells(5, 3), _
                DropDown.ws_company.Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible)

        DropDown.ws_company.Range("C2") = Cell

        pptVorlage = myfilename
        Debug.Print (myfilename)

        Set PP = pptApp.Presentations.Open(pptVorlage)

        newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")

        PP.UpdateLinks
        PP.SaveAs newpath

        newpathpdf = Replace(newpath, "pptx", "pdf")
        Debug.Print (newpathpdf)
        PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF, ppFixedFormatIntentPrint

        pptApp.Presentations(newpath).Close

        Set PP = Nothing
    Next

    ' this part below closes PPT application if there are no other presentation
    ' object open. If there is at least 1, it leaves it open
    If IsAppRunning("PowerPoint.Application") Then
        If pptApp.Windows.Count = 0 Then
            pptApp.Quit
        End If
    End If
    Set pptApp = Nothing
    Set PP = Nothing

End Sub

Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
    On Error Resume Next
    Set oApp = GetObject(, sAppName)
    If Not oApp Is Nothing Then
        Set oApp = Nothing
        IsAppRunning = True
    End If
End Function

Answer 1

我没有发现任何明显的错误，但我可以为您提供调试策略。

您将需要单独测试所有主要操作。您将需要在调试器中运行每个测试并打开屏幕更新，以便您可以看到发生了什么:

• 测试文件选择器

• 测试 GetObject/CreateObject - 您真的需要它吗？您似乎已经打开了 PowrPoint；

• 使用单个硬编码值测试您的循环。打开演示文稿时焦点会发生什么变化？

• 尝试不使用 UpdateLinks；尝试不使用 SaveAs 并尝试不使用 Export(即仅打开演示文稿并再次关闭)。

• 检查演示文稿是否确实关闭，否则您最终可能会打开大量演示文稿。

• 测试关闭应用程序

• 测试从下拉框中读取内容

• 测试 IsAppRunning 函数。请注意，它会设置 On Error Resume Next 但不会重置它。请注意，它不会在任何地方设置 IsAppRunning = False。

• 在进行或不进行调试的情况下循环尝试上述相关部分，看看会发生什么并查看它是否崩溃 - Office 应用程序中可能存在计时问题，例如尝试在演示文稿尚未完全加载时对其进行操作。

最小化代码可以帮助隔离导致问题的区域。我希望这会有所帮助。