Supercharge your PowerPoint productivity with
Supercharge your PPT Productivity with PPTools - Click here to learn more.

Proud member of

PPTools

Image Export converts PowerPoint slides to high-quality images.

PPT2HTML exports HTML even from PowerPoint 2010 and 2013, gives you full control of PowerPoint HTML output, helps meet Section 508 accessibility requirements

Merge Excel data into PowerPoint presentations to create certificates, awards presentations, personalized presentations and more

Resize your presentations quickly and without distortion

Language Selector switches the text in your presentation from one language to another

FixLinks prevents broken links when you distribute PowerPoint presentations

Shape Styles brings styles to PowerPoint. Apply complex formatting with a single click.

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


Did this solve your problem? If so, please consider supporting the PPT FAQ with a small PayPal donation.
Page copy protected against web site content infringement by Copyscape Contents © 1995 - 2022 Stephen Rindsberg, Rindsberg Photography, Inc. and members of the MS PowerPoint MVP team. You may link to this page but any form of unauthorized reproduction of this page's contents is expressly forbidden.

Supercharge your PPT Productivity with PPTools

content authoring & site maintenance by
Friday, the automatic faq maker (logo)
Friday - The Automatic FAQ Maker

Add a "thermometer" progress bar to each slide
http://www.pptfaq.com/FAQ00597_Add_a_-thermometer-_progress_bar_to_each_slide.htm
Last update 07 June, 2011
Created: