Consulting

Results 1 to 8 of 8

Thread: VBA function running continuously in PowerPoint?

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    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.

    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
    Attached Files Attached Files
    Last edited by georgiboy; 04-08-2024 at 05:30 AM. Reason: Edited code tags

  2. #2
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,246
    Location
    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
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved
    Click here for a guide on how to upload a file with your post

    Excel 365, Version 2405, Build 17628.20102

  3. #3
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,246
    Location
    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
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved
    Click here for a guide on how to upload a file with your post

    Excel 365, Version 2405, Build 17628.20102

  4. #4
    Hi again

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

  5. #5
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,246
    Location
    What line of code do you get the error on?
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved
    Click here for a guide on how to upload a file with your post

    Excel 365, Version 2405, Build 17628.20102

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

  7. #7
    Moderator VBAX Master georgiboy's Avatar
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    1,246
    Location
    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
    Click here for a guide on how to add code tags
    Click here for a guide on how to mark a thread as solved
    Click here for a guide on how to upload a file with your post

    Excel 365, Version 2405, Build 17628.20102

  8. #8
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,747
    Location
    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>
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •