Excel VBA Code crashes PPT Presentation and lead to Error 462

Hallo,

you guys are my lost hope. Nobody and nothing was able to help me so far, not google, not Stackoverflow, no other experts.

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: https://drive.google.com/open?id=1D3Co_JfGmRsW18DeLFe1QJtApFgS2WDT

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

Application.EnableEvents = 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") 'what is this needed here ?





'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

Call RefreshDataEachHour



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




Public Sub RefreshDataEachHour()



Application.OnTime Now + TimeValue("00:00:10"), "Saveas_PPT_and_PDF"



End Sub