1 Attachment(s)
VBA function running continuously in PowerPoint?
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.
Code:
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