Add a "thermometer" progress bar to each slide

Problem

You'd like to have some on-slide indication of how far along in a presentation you are so you can better judge how to use the time remaining for your talk.

Solution

If you're not the Do It Yourself type, Geetesh Bajaj has already created a nice Thermometer for PowerPoint for you, ready to load and run. It's based on the code you see below but has several nice additions.

The following AddProgressBars macro will add a thin rectangle to the bottom of each slide. The width of the rectangle will be proportional to how far along the slide is in the presentation. In other words, on the 10th slide of a 20-slide presentation, the rectangle will be half the width of the slide. On the 20th slide, it'll be the full width of the slide.

The RemoveProgressBars macro will remove the rectangles that AddProgressBars adds.

Sub AddProgressBars()

    Dim X As Long
    Dim dblLeft As Double
    Dim dblTop As Double
    Dim dblheight As Double
    Dim oSh As Shape

    ' This determines how far in from left the progress bar will start:
    dblLeft = 0
    ' This determines how high (in points) the progress bar will be:
    dblheight = 12
    ' This puts the progress bar right against the bottom of the slide, no matter what its height
    dblTop = ActivePresentation.PageSetup.Slideheight - dblheight

    For X = 1 To ActivePresentation.Slides.Count
        ' Add a rectangle - it'll be formatted however you have your default object formatting set
        Set oSh = ActivePresentation.Slides(X).Shapes.AddShape(msoShapeRectangle, _
            dblLeft, _
            dblTop, _
            (X * ActivePresentation.PageSetup.Slidewidth) / ActivePresentation.Slides.Count, _
            dblheight)
        With oSh
            ' Change this to any color you like, if you like
            .Fill.ForeColor.RGB = RGB(127, 0, 0)

            ' Don't change this:
            .Name = "ThermometerBar"
        End With
    Next X

End Sub

Sub RemoveProgressBars()

    Dim X As Long

    On Error Resume Next
    For X = 1 To ActivePresentation.Slides.Count
        ActivePresentation.Slides(X).Shapes("ThermometerBar").Delete
    Next X

End Sub

See How do I use VBA code in PowerPoint? to learn how to use this example code.

Search terms:thermometer,progress,bar,gauge

---