VBA Code вылетает приложение PPT - неясная причина - PullRequest
Новая
       6

VBA Code вылетает приложение PPT - неясная причина

0 голосов
/ 11 января 2019

У меня проблема со следующим кодом. Что происходит, так это то, что мое приложение 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

1 Ответ

0 голосов
/ 11 января 2019

Я не вижу ничего явно неправильного, но могу дать вам стратегию отладки.

Вы захотите проверить все основные манипуляции отдельно. Вы захотите запустить каждый тест в отладчике и включить обновление экрана, чтобы увидеть, что происходит:

  • проверить средство выбора файла

  • test GetObject / CreateObject - он вам действительно нужен? Кажется, вы уже открыли PowrPoint;

  • проверить ваш цикл с одним жестко закодированным значением. Что происходит с фокусом при открытии презентации?

  • попробуйте без UpdateLinks; попробуйте без SaveAs и попробуйте без экспорта (т.е. просто откройте презентацию и закройте ее снова).

  • проверьте, действительно ли закрывается презентация, в противном случае вы можете получить множество открытых презентаций.

  • тест закрытия приложения

  • тестовое чтение из выпадающего списка

  • проверить функцию IsAppRunning. Обратите внимание, что он устанавливает On Error Resume Next, но не сбрасывает его. Обратите внимание, что он не устанавливает IsAppRunning = False в любом месте.

  • попробуйте соответствующие части вышеперечисленного в цикле с отладкой и без нее, чтобы увидеть, что происходит, и посмотреть, не происходит ли сбой - может быть проблема с синхронизацией в приложении Office, например, пытается манипулировать презентацией, пока она еще не загружена полностью.

Минимизация вашего кода может помочь изолировать область, которая вызывает проблему. Надеюсь, это поможет.

...