Excel VBA Code crashes PPT Presentation and leads to Error 462

[MSCom]

Hallo,


I have a Code, which starts in Excel and opens a PPT, updates the links, renames the PPT and closes it. The problem: Sometimes (not always) the PPT Presentation crashes and my code stops running, resulting in the following error message: "Error 462 the remote server machine does not exist or is unavailable"

The PPT seems to crash in different parts of the code but mostly at "Set PP = pptApp.Presentations.Open(pptVorlage)". Sometimes the code works fine for 50 loops, sometimes crashes after the first one.

Link to the files: Link

Please help me, it has already cost me days :/

Kind regards and thanks in advance for your help
Michael







Code:


Option Explicit
Public myfilename As String


Sub Saveas_PPT_and_PDF()

Set ws_company = Tabelle2

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

Application.ScreenUpdating = False

pptVorlage = "C:\Users\Michael\Desktop\Test PPT\MSO Tester.pptx"

company = Dropdown.ws_company.Range("C2").Value

Set pptApp = CreateObject("PowerPoint.Application")

Dim drop As Range
Set drop = ws_company.Range(ws_company.Cells(5, 3), ws_company.Cells(Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible)

For Each Cell In drop

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


'Set PP = Nothing
Set PP = pptApp.Presentations.Open(pptVorlage)'often I get the error message here, so it must crash before this part, correct?

newpath = Replace(pptVorlage, "MSO", "" & Cell & "MSO")


'Application.Wait (Now + TimeValue("0:00:05"))
PP.UpdateLinks
PP.SaveAs newpath

newpathpdf = Replace(newpath, "pptx", "pdf")

PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF, ppFixedFormatIntentPrint

'pptApp.Presentations(newpath).Close
PP.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
Else
IsAppRunning = False
End If
End Function