Vba – Add a counter to a Power Point Presentation

counterpowerpointvba

I would like to add a counter to a power point presentation. Someone mentioned to me that this might be doable in VBA. Do you know if this could be done in VBA and how?

Basically here is what I would like to do:
display a counter representing for example the number of cars rented since the beginning of my presentation. So for example, at the start the counter is at 0 and every minute is incremented of 2000 (this is just an example). We can see the counter on every slide, so at the end of my talk people can see (and I'll tell them) that since the beginning of the talk X(large number) cars have been rented.

I tried to find something on the internet but without success… I hope someone will be able to help me?

Best Answer

I give you some ideas. Possibly they will be helpful even I do not provide any code.

  1. Generally you need to have something like 'timer' in your presentation which would start with your presentation and count the time used. Unfortunately there is nothing like this in PowerPoint. You could possibly use some external solution like C# COM add-in but it's rather very complicated.

  2. You could use PP application events but value of the car will not change every minute but every new slide you enter or any other event fires (like moving reverse, etc). It's a bit complicated but within our (StackOverflow users) knowledge.

You could possible search or ask under that link where I used to find lot's of interesting ideas.

I promised to provide solution therefore I'd like to do it even the question is closed. Therefore I do it by re-edition of that answer which I hope is allowed.

  1. We have to be sure that there is a 'text box' where 'count value' would be placed on each slide. Add the following code into Module1 and run it. 

    Sub Add_CarValue_Text()

Dim SLD As Slide, SHP As Shape, shCarValue As Shape
Dim boCarValue As Boolean

For Each SLD In ActivePresentation.Slides
    For Each SHP In SLD.Shapes
        If SHP.Name = "CarValue" Then
            boCarValue = True
            Exit For
        End If
    Next

    If Not boCarValue Then
        Set shCarValue = SLD.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 150, 50)
        With shCarValue
            .Name = "CarValue"
            .TextFrame.TextRange.Text = "Cars counter: "
        End With

    End If
    boCarValue = False
Next
End Sub

  2. Add new Class Module and place below code there. Change if necessary.

    Public WithEvents PPApp As Application

Private TimerStart As Long
Private Const increasePerMinute = 1000

Private Sub PPApp_SlideShowBegin(ByVal Wn As SlideShowWindow)
    TimerStart = Int(Timer)
End Sub

Private Sub PPApp_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
    If Not Wn.View.Slide.Shapes("CarValue") Is Nothing Then
        Dim Lap As Integer
        Lap = (Int(Timer) - TimerStart) / 10 'change for 60 to change from 10sec to 1 min
        Wn.View.Slide.Shapes("CarValue").TextFrame.TextRange = "Cars volume: " & Lap * increasePerMinute
    End If
End Sub

  3. Add the following code to Module2 and run the procedure.

    Public tmpPPApp As New AppClass
Sub StartUp()
    Set tmpPPApp.PPApp = PowerPoint.Application
End Sub

  4. Start your presentation.

Important! If you change anything in code please run step 3 again. Moreover, just in case, you need to run procedure 3 always before you lunch the presentation.

Related Topic