VBA function running continuously in PowerPoint?

[Paul_Hossler]

1. I used a timer API that starts when the Slide SHow Start event fires. You need a Class for that

Option Explicit


Public WithEvents App As Application


'Private Sub App_PresentationClose(ByVal Pres As Presentation)
'    IsTimerOff = True
'    Call TimerOnOff
'End Sub
'
'Private Sub App_PresentationOpen(ByVal Pres As Presentation)
'    IsTimerOff = False
'    Call TimerOnOff
'End Sub


Private Sub App_SlideShowBegin(ByVal Wn As SlideShowWindow)
    IsTimerOff = False
    Call TimerOnOff
End Sub


Private Sub App_SlideShowEnd(ByVal Pres As Presentation)
    IsTimerOff = True
    Call TimerOnOff
End Sub

2. I used a different connection sub since my AV didn't like yours

'https://www.access-programmers.co.uk/forums/threads/vba-code-to-check-internet-connection-in-windows-os-64-bit-vba-ms-access-2019.320847/
Option Explicit


Public Flg As LongPtr
Public Declare PtrSafe Function InternetGetConnectedState _
    Lib "Wininet.dll" (lpdwFlags As LongPtr, _
    ByVal dwReserved As Long) As Boolean


Private Const INTERNET_CONNECTION_MODEM As Long = &H1
Private Const INTERNET_CONNECTION_LAN As Long = &H2
Private Const INTERNET_CONNECTION_PROXY As Long = &H4
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8
Private Const INTERNET_RAS_INSTALLED As Long = &H10
Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40


Function IsInternetOk() As Boolean
    Dim INTNET As Long


    INTNET = InternetGetConnectedState(Flg, 0&)


    If Flg >= INTERNET_CONNECTION_OFFLINE Then
        Debug.Print "INTERNET_CONNECTION_OFFLINE"
    End If


    If CBool(INTNET) Then
        IsInternetOk = True
    Else
        IsInternetOk = False
    End If
End Function

3. The main code and the color changing is in another module. I really couldn't test the connected / not connected part, i just wanted to see the timer part

' --------------------------------------------------------------------------------
' Copyright ©1999-2018, Shyam Pillai, All Rights Reserved.
'   http://skp.mvps.org/ppt00021.htm
'--------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
'
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
'
'--------------------------------------------------------------------------------


Const NumSeconds As Long = 3


Option Explicit


'API Declarations
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
 
' Public Variables
Public TimerID As Long
Public IsTimerOff As Boolean




Sub TimerOnOff()


    If IsTimerOff = False Then
         TimerID = SetTimer(0, 0, NumSeconds * 1000, AddressOf TimerProc)


         If TimerID = 0 Then
             MsgBox "Unable to create the timer", vbCritical + vbOKOnly, "Error"
            Exit Sub
        End If


        IsTimerOff = True


    Else
        TimerID = KillTimer(0, TimerID)


        If TimerID = 0 Then
            MsgBox "Unable to stop the timer", vbCritical + vbOKOnly, "Error"
        End If


        IsTimerOff = False
    End If
 End Sub


 
Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    
    Dim hshp As Shape
    Dim osld As Slide
    
    'for testing
    ActivePresentation.Slides(1).Shapes("Test").TextFrame.TextRange.text = Format(Now, "hh:mm:ss")
    
    
    For Each osld In ActivePresentation.Slides
        For Each hshp In osld.Shapes
            With hshp
                If Not .Name Like "GoogleShape*" Then GoTo NextShape
                                      
                Select Case IsInternetOk
                    Case True
                        .Fill.ForeColor.RGB = RGB(255, 255, 255)
                        .Fill.Solid
                    Case False
                      .Fill.ForeColor.RGB = RGB(50, 50, 50)
                      .Fill.Solid
                End Select
            End With
NextShape:
        Next hshp
    Next osld
End Sub

4. I used the CustomUI onload to initialize the class

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="InitializeApp">
</customUI>