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>