Consulting

Results 1 to 7 of 7

Thread: Implementing a Timer on a Slide using VBA

  1. #1
    VBAX Regular
    Joined
    May 2011
    Posts
    14
    Location

    Implementing a Timer on a Slide using VBA

    Hi there,

    I was able to get this piece of code from John Wilson to implement a timer on my slide using VBA:

    Sub Time_Me()
    Dim oshp As Shape
    Dim oshpRng As ShapeRange
    Dim osld As Slide
    Dim oeff As Effect
    Dim i As Integer
    Dim Iduration As Integer
    Dim Istep As Integer
    Dim dText As Date
    Dim texttoshow As String
    On Error GoTo errhandler
    If ActiveWindow.Selection.ShapeRange.Count > 1 Then
    MsgBox "Please just select ONE shape!"
    Exit Sub
    End If
    Set osld = ActiveWindow.Selection.SlideRange(1)
    Set oshp = ActiveWindow.Selection.ShapeRange(1)
    oshp.Copy

    'change to suit
    Istep = 5
    Iduration = 120 'in seconds

    For i = Iduration To 0 Step -Istep
    Set oshpRng = osld.Shapes.Paste
    With oshpRng
    .Left = oshp.Left
    .Top = oshp.Top
    End With
    dText = CDate(i \ 3600 & ":" & ((i Mod 3600) \ 60) & ":" & (i Mod 60))
    If Iduration < 3600 Then
    texttoshow = Format(dText, "Nn:Ss")
    Else
    texttoshow = Format(dText, "Hh:Nn:Ss")
    End If
    oshpRng(1).TextFrame.TextRange = texttoshow
    Set oeff = osld.TimeLine.MainSequence _
    .AddEffect(oshpRng(1), msoAnimEffectFlashOnce, , msoAnimTriggerAfterPrevious)
    oeff.Timing.Duration = Istep
    Next i
    oshp.Delete
    Exit Sub
    errhandler:
    MsgBox "**ERROR** - Maybe nothing is selected?"
    End Sub

    PROBLEM


    John says "Simply create ONE shape or textbox with text in the style you need (Any text will do but make it as long as the longest possible time), select it and run the macro below."

    For some reason unfortunately, I do not seem to be able to get it to work.

    Can someone help me point out what I am doing wrong?

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    So, what happens when you try?

    What should happen is the macro duplicates the shape you added but with appropriate "Time Text" then add animation to show the shapes in the correct order when in show mode.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Regular
    Joined
    May 2011
    Posts
    14
    Location
    Hi John,

    So i finally managed to get the code working and improvised for what I want it to do. Here's what I come up with finally.

    Sub Tmr()
    Dim TMinus As Integer
    Dim xtime As Date

    With ActivePresentation.Slides(5)
    With .Shapes(1)
    'Countdown in seconds
    TMinus = 30
    Do While (TMinus > -1)
    'Suspend program execution for 1 second (1000 milliseconds)
    Sleep 1000
    xtime = Now
    .TextFrame.TextRange.Text = Format(TimeValue(Format(Now, "hh:mm:ss")) - TimeSerial(Hour(Now), Minute(Now), Second(Now) + TMinus), "hh:mm:ss")
    TMinus = TMinus - 1
    'Very crucial else the display won't refresh itself
    DoEvents
    Loop
    End With
    End With

    End Sub

    This is now, as you will notice, a simpler version where a 30 second timer runs when the shape (enabled with the Tmr Macro) is clicked.

    However, i now want the time to be displayed only in SECONDS (as opposed to hh:mm:ss and unfortunately due to my inexperience in VBA I am not aware of a function which can do that. I will greatly appreciate your help if you can advise.

    The next step is to be able to stop this counter when I jump to another slide and then continue the timer counter from where I left it when I come back to the slide which contains the Timer Shape.

    Any guidance will be greatly appreciated

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    Using API calls is not a good idea if you are not a competant programmer. I wouldn't go there. The sleep API will prevent anything else happening. You could use the SetTimer API but that is even more tricky to use properly.

    Also you should credit the author (Shyam Pillai) when you post his code.

    If you insist though you could try this:

    [VBA]#If VBA7 Then
    ' allows for 64 bit
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #End If
    Sub Tmr()
    Dim TMinus As Integer
    'Countdown in seconds
    TMinus = 10
    With ActivePresentation.Slides(1).Shapes(1)
    Do While (TMinus > -1)
    'Suspend program execution for 1 second (1000 milliseconds)
    Sleep 1000
    TMinus = TMinus - 1
    .TextFrame.TextRange = CStr(TMinus + 1) & "Secs"
    'Very crucial else the display won't refresh itself
    DoEvents
    Loop
    End With
    End Sub[/VBA]

    If you want a timer running across the opresentation I would search for a free windows desktop timer. Most of these will run in front of your presentation.
    Last edited by John Wilson; 05-29-2011 at 03:29 AM.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    VBAX Regular
    Joined
    May 2011
    Posts
    14
    Location
    A genius...John Wilson...thanks!
    And indeed I have also credited Shyam Pillai as a comment in my code.

    Now the entire purpose of such a timer in my application is that When I run another macro (by clicking an action button) the timer should stop, run the other sub routine, and when that routine is done, the timer should continue.

    Going by your statement that the Sleep API will prevent anything else from happening, is the above achievable? If so, I would sincerely appreciate your guidance.

    Thanks again for your expert advice.

  6. #6
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    The sleep APi basically puts the PC to sleep. So ... It probably won't see the click on the button.

    SetTimer is the way to do this but you really need to know what you are doing/ SetTimer calls a macro memory location every xxxx micro seconds. This will do what you need BUT if anything is wrong and the called macro is not at that locatiion or throws an error you will totally crash the PC. Shyam has sample code on the same page but be careful! If you are able to adapt it so KillTimer is always called on error try it ... Don't blame me (or Shyam) when it crashes though!

    You should make sure the Timer is killed when the slide show ends

    You could add this in the TimerProc

    [vba]If SlideShowWindows.Count < 1 Then
    bTimerState = True
    Call TimerOnOff
    Exit Sub
    End If[/vba]
    It IS not completely foolproof though
    Last edited by John Wilson; 05-30-2011 at 09:43 AM.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  7. #7
    VBAX Regular
    Joined
    May 2011
    Posts
    14
    Location

    Still having some Trouble

    Hi John,

    Thanks for the suggestion, however, Shyam Pillai's SetTimer code counts from 1 upward. I tried to modify to count from 30 downward by initializing the SecondCtr = 30. The code keeps crashing on me.

    Is there something I am doing incorrectly?

    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 SecondCtr As Integer
    Public TimerID As Long
    Public bTimerState As Boolean
    Sub TimerOnOff()
    If bTimerState = False Then
    TimerID = SetTimer(0, 0, 1000, AddressOf TimerProc)
    If TimerID = 0 Then
    MsgBox "Unable to create the timer", vbCritical + vbOKOnly, "Error"
    Exit Sub
    End If
    bTimerState = True
    Else
    TimerID = KillTimer(0, TimerID)
    If TimerID = 0 Then
    MsgBox "Unable to stop the timer", vbCritical + vbOKOnly, "Error"
    End If
    bTimerState = False
    End If
    End Sub
    ' The defined routine gets called every nnnn milliseconds.
    Sub TimerProc(ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal idEvent As Long, _
    ByVal dwTime As Long)


    SecondCtr = 30

    SecondCtr = SecondCtr - 1
    ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange.Text = CStr(SecondCtr)

    End Sub

Posting Permissions

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