Option Explicit
Dim g
Dim ppt As Object
'Dim ppt As PowerPoint.Application
Dim pres As Object
 
'Activates current screensaver
'If you use this code give me some credit
 
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal _
  hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) _
  As Long
 
Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
 Dim startSS As Long
 
 
 
'Dim pres As PowerPoint.Presentation
Sub pptProperties_anpassen()
On Error Resume Next
Set ppt = GetObject(, "PowerPoint.Application")
If ppt Is Nothing Then
Set ppt = CreateObject("PowerPoint.Application")
End If
ppt.Activate
Set pres = ppt.Presentations.Open("D:\Eigene Dateien\proventus\Neuer" & _
  "Ordner\test.pps")
'Set ppt = Nothing
'Set pres = Nothing
End Sub
 
Private Sub Command1_Click()
zeit    'pptProperties_anpassen
End Sub
Private Sub zeit()
neu:
beenden
g = 0
Dim Pausenlänge, Start, ende, Gesamtdauer
'If (MsgBox("5 Sekunden Pause?", 4)) = vbYes Then
    Pausenlänge = 10   ' Dauer festlegen.
    Start = Timer    ' Anfangszeit setzen.
    Do While Timer < Start + Pausenlänge
       'g = DoEvents
      If g = 0 Then
     pptProperties_anpassen '
        g = 1
       End If
    Loop
    ende = Timer    ' Ende festlegen.
    ppt.quit    ' Gesamtdauer berechnen.
 'startSS = SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 1&)
 Dim Ergebnis
g = 0
   'StartScreenSaver Me.hWnd
  Pausenlänge = 10   ' Dauer festlegen.
    Start = Timer    ' Anfangszeit setzen.
    Do While Timer < Start + Pausenlänge
       'g = DoEvents
      If g = 0 Then
     Ergebnis = Shell("D:\Eigene Dateien\proventus\Neuer Ordner\Aquatica" & _
       "Waterworlds.exe /s", 4)
 
        g = 1
       End If
    Loop
    ende = Timer    ' Ende festlegen.
'   SendMessage Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, ByVal -1&  geht nicht
   GoTo neu
End Sub
Sub beenden()
SendKeys "{ENTER}"
End Sub