Question

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

我尝试了application.wait方法，但是没有用。

感谢

帮助，因为我已经在此工作了几天-.-。预先感谢。

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并尝试不使用导出（即，仅打开演示文稿然后再次关闭）。
检查演示文稿是否真正关闭，否则您可能会得到很多打开的演示文稿。
测试关闭应用程序
从下拉框中测试读数
测试IsAppRunning函数。请注意，它设置了On Error Resume Next，但没有将其重置。请注意，它不会在任何地方设置IsAppRunning = False。
在有和没有调试的情况下循环尝试上述内容，以查看发生了什么并查看是否崩溃-Office应用程序中可能存在计时问题，例如尝试在演示文稿尚未完全加载时对其进行操作。

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

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

1 个答案: