VBA function running continuously in PowerPoint?

[mads husted]

Hello VBA experts

Im work on a ship in the north atlantic ocean, where we like all others are using satellite communication.
Its part of my job to keep it running, but unstable connection makes pople call my all the time. So on the televisions we have a PowerPoint running in loob with information.
I have a VBA that are displaying a figure off the internet status. Its change coloer if we loose the internet.

I can get it to run automatically when I open the PowerPoint by using a shortcut and add the text
"C:\Program Files (x86)\Microsoft Office\Office16\POWERPNT.EXE" /M "C:\InfoTV\Powerpoint figur internet status\Powerpoint status.pptm" "changedcolor

Hers the problem, its only run one time, how to make it to run continuously?

You can see my code and I have Attach my powerpoint.

In advanced thanks.

Sub changedcolor()
    Dim hshp As Shape
    Dim osld As Slide
    
    For Each osld In ActivePresentation.Slides
        For Each hshp In osld.Shapes
            With hshp
                If .Name Like "GoogleShape*" And IsConnected = True Then
                    .Fill.ForeColor.RGB = RGB(255, 255, 255)
                    .Fill.Solid
                ElseIf .Name Like "GoogleShape*" And IsConnected = False Then
                    .Fill.ForeColor.RGB = RGB(50, 50, 50)
                    .Fill.Solid
                End If
            End With
        Next hshp
    Next osld
End Sub


Public Function IsConnected()
    Dim objFS As Object
    Dim objShell As Object
    Dim objTempFile As Object
    Dim strLine As String
    Dim strFileName As String
    Dim strHostAddress As String
    Dim strTempFolder As String
    
    strTempFolder = "C:\PingTemp"
    strHostAddress = "8.8.4.4"
    IsConnected = True ' Assume success
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    
    If Dir(strTempFolder, vbDirectory) = "" Then
        MkDir strTempFolder
    End If
    
    strFileName = strTempFolder & "" & objFS.GetTempName
    If Dir(strFileName) <> "" Then
        objFS.DeleteFile (strFileName)
    End If
    
    objShell.Run "cmd /c ping " & strHostAddress & " -n 1 -w 1 > " & strFileName, 0, True
    Set objTempFile = objFS.OpenTextFile(strFileName, 1)
    Do While objTempFile.AtEndOfStream <> True
        strLine = objTempFile.Readline
        If InStr(1, UCase(strLine), "REQUEST TIMED OUT.") > 0 Or InStr(1, UCase(strLine), "COULD NOT FIND HOST") > 0 Then
            IsConnected = False
        End If
    Loop
    objTempFile.Close
    objFS.DeleteFile (strFileName)
    objFS.DeleteFolder (strTempFolder)
End Function

[georgiboy]

Hi mads husted,

I have moved your thread from the Outlook forum to the PowerPoint forum so that it will get more visibility.

I have also added code tags to your code, you can click on the link in my signature to see how to add code tags for future posts.

I am sure someone will be along shortly to help you with your code.

Cheers

georgiboy

[georgiboy]

As you have had no success with anyone helping, here is my attempt. If you run your 'changedcolor' macro below then it should run every 20 seconds until you either stop it in the VBE or close the file. The macro will not run itself when you open the file but once you run it, it will run every 20 seconds, you can change the interval it runs by editing the number in the Wait (20) part to how ever many seconds you would like.

Sub changedcolor()
    Dim ic As Boolean
    Dim hshp As Shape
    Dim osld As Slide
    
    Do
        ic = IsConnected
        For Each osld In ActivePresentation.Slides
            For Each hshp In osld.Shapes
                With hshp
                    If .Name Like "GoogleShape*" And ic Then
                        .Fill.ForeColor.RGB = RGB(255, 255, 255)
                        .Fill.Solid
                    ElseIf .Name Like "GoogleShape*" And Not ic Then
                        .Fill.ForeColor.RGB = RGB(50, 50, 50)
                        .Fill.Solid
                    End If
                End With
            Next hshp
        Next osld
        Wait (20)
    Loop
End Sub


Public Function IsConnected()
    Dim objFS As Object
    Dim objShell As Object
    Dim objTempFile As Object
    Dim strLine As String
    Dim strFileName As String
    Dim strHostAddress As String
    Dim strTempFolder As String
    
    strTempFolder = "C:\PingTemp"
    strHostAddress = "8.8.4.4"
    IsConnected = True ' Assume success
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    
    If Dir(strTempFolder, vbDirectory) = "" Then
        MkDir strTempFolder
    End If
    
    strFileName = strTempFolder & "" & objFS.GetTempName
    If Dir(strFileName) <> "" Then
        objFS.DeleteFile (strFileName)
    End If
    
    objShell.Run "cmd /c ping " & strHostAddress & " -n 1 -w 1 > " & strFileName, 0, True
    Set objTempFile = objFS.OpenTextFile(strFileName, 1)
    Do While objTempFile.AtEndOfStream <> True
        strLine = objTempFile.Readline
        If InStr(1, UCase(strLine), "REQUEST TIMED OUT.") > 0 Or InStr(1, UCase(strLine), "COULD NOT FIND HOST") > 0 Then
            IsConnected = False
        End If
    Loop
    objTempFile.Close
    objFS.DeleteFile (strFileName)
    objFS.DeleteFolder (strTempFolder)
End Function


Function Wait(wt As Long)
    Dim start As Long
    
    start = Timer
    While Timer < start + wt
        DoEvents
    Wend
End Function

Hope this helps

[mads husted]

Hi again

Thanks for the reply, but unfortunately its not working, the code Public Function IsConnected makes an error, with the new add code.

[georgiboy]

What line of code do you get the error on?

[mads husted]

I get a Run Time error 53: file not fund, in the line Set objTempFile = objFS.OpenTextFile(strFileName, 1)

[georgiboy]

I think the code is now running past the shell command that is creating the file you are trying to open, this may be due to adding in the DoEvents.

Try the below, I have added in a 5 second wait after the shell command to allow it time to create the file before the code tries to open it.

I have edited it so it should run roughly every 30 seconds, this can be edited if you wish by changing the time in the first 'Wait'. Currently 25 seconds plus the 5 seconds for shell part makes a 30 second loop. If you make the first wait 55 seconds then it should loop roughly every 60 seconds etc..

Option Explicit

Sub changedcolor()
    Dim ic As Boolean
    Dim hshp As Shape
    Dim osld As Slide
    
    Do
        ic = IsConnected
        For Each osld In ActivePresentation.Slides
            For Each hshp In osld.Shapes
                With hshp
                    If .Name Like "GoogleShape*" And ic Then
                        .Fill.ForeColor.RGB = RGB(255, 255, 255)
                        .Fill.Solid
                    ElseIf .Name Like "GoogleShape*" And Not ic Then
                        .Fill.ForeColor.RGB = RGB(50, 50, 50)
                        .Fill.Solid
                    End If
                End With
            Next hshp
        Next osld
        Wait (25)
    Loop
End Sub




Public Function IsConnected()
    Dim objFS As Object
    Dim objShell As Object
    Dim objTempFile As Object
    Dim strLine As String
    Dim strFileName As String
    Dim strHostAddress As String
    Dim strTempFolder As String
    
    strTempFolder = "C:\PingTemp"
    strHostAddress = "8.8.4.4"
    IsConnected = True ' Assume success
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Wscript.Shell")
    
    If Dir(strTempFolder, vbDirectory) = "" Then
        MkDir strTempFolder
    End If
    
    strFileName = strTempFolder & "" & objFS.GetTempName
    If Dir(strFileName) <> "" Then
        objFS.DeleteFile (strFileName)
    End If
    
    objShell.Run "cmd /c ping " & strHostAddress & " -n 1 -w 1 > " & strFileName, 0, True
    Wait (5)
    Set objTempFile = objFS.OpenTextFile(strFileName, 1)
    Do While objTempFile.AtEndOfStream <> True
        strLine = objTempFile.Readline
        If InStr(1, UCase(strLine), "REQUEST TIMED OUT.") > 0 Or InStr(1, UCase(strLine), "COULD NOT FIND HOST") > 0 Then
            IsConnected = False
        End If
    Loop
    objTempFile.Close
    objFS.DeleteFile (strFileName)
    objFS.DeleteFolder (strTempFolder)
End Function




Function Wait(wt As Long)
    Dim start As Long
    
    start = Timer
    While Timer < start + wt
        DoEvents
    Wend
End Function

[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>