Insert a progress bar to Powerpoint presentation

Insert a progress bar to Powerpoint presentation .md

Intro

To view the progress of a Powerpoint presentation, a progress bar can be displayed at the bottom of the slide show.

How to proceed

Once the slideshow is complete, go to Tools > Macro > Visual Basic Editor.

In the new window, select Insert > Module and copy this text in the blank page:

Sub AddProgressBar()
    On Error Resume Next
        With ActivePresentation
              sHeight = .PageSetup.SlideHeight - 12
              n = 0
              j = 0
              For i = 1 To .Slides.Count
                If .Slides(i).SlideShowTransition.Hidden Then j = j + 1
              Next i:
              For i = 2 To .Slides.Count
                .Slides(i).Shapes("progressBar").Delete
                If .Slides(i).SlideShowTransition.Hidden = msoFalse Then
                  Set slider = .Slides(i).Shapes.AddShape(msoShapeRectangle, 0, sHeight, (i - n) * .PageSetup.SlideWidth / (.Slides.Count - j), 12)
                  With slider
                      .Fill.ForeColor.RGB = ActivePresentation.SlideMaster.ColorScheme.Colors(ppFill).RGB
                      .Name = "progressBar"
                  End With
                Else
                   n = n + 1
                End If
              Next i:
        End With
End Sub

Then go to File > Close > Return to Microsoft PowerPoint In the displayed page of Microsoft Powerpoint, go to: Tools > Macro > Macros, then select AddProcessBar and press Execute

How remove the progress bar?

To remove the progress bar make we can add the following function:

Sub RemoveProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
              .Slides(i).Shapes("progressBar").Delete
              Next i:
        End With
End Sub

PPT-Progress-Bar-with-Page-Numbers.vbs

'' Add progress bar and page numbers to all non-hidden pages
Sub AddProgressBar()
    On Error Resume Next
        With ActivePresentation
              sHeight = .PageSetup.SlideHeight - 12
              n = 0
              j = 0
              For i = 1 To .Slides.Count
                If .Slides(i).SlideShowTransition.Hidden Then j = j + 1
              Next i:
              For i = 2 To .Slides.Count
                .Slides(i).Shapes("progressBar").Delete
                .Slides(i).Shapes("pageNumber").Delete
                If .Slides(i).SlideShowTransition.Hidden = msoFalse Then
                  Set slider = .Slides(i).Shapes.AddShape(msoShapeRectangle, 0, sHeight, (i - n) * .PageSetup.SlideWidth / (.Slides.Count - j), 12)
                  With slider
                      .Fill.ForeColor.RGB = ActivePresentation.SlideMaster.ColorScheme.Colors(ppFill).RGB
                      .Name = "progressBar"
                  End With
                  Set pageNumber = .Slides(i).Shapes.AddTextbox(msoTextOrientationHorizontal, ((i - n) * .PageSetup.SlideWidth / (.Slides.Count - j)) - 40, .PageSetup.SlideHeight - 15, 100, 10)
                  With pageNumber
                      .TextFrame.TextRange.Text = Str(i - n) & "/" & Str(ActivePresentation.Slides.Count - j)
                       With .TextFrame.TextRange.Font
                           .Bold = msoFalse
                           .Size = 10
                       End With
                       .Name = "pageNumber"
                   End With
                  Else
                    n = n + 1
                  End If
              Next i:
        End With
End Sub

'' Macro to remove the progress bar from all the slides
Sub RemoveProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
              .Slides(i).Shapes("progressBar").Delete
              .Slides(i).Shapes("pageNumber").Delete
              Next i:
        End With
End Sub

PPT-Progress-Bar.vbs

'' Add progress bar only to all non-hidden pages
Sub AddProgressBar()
    On Error Resume Next
        With ActivePresentation
              sHeight = .PageSetup.SlideHeight - 12
              n = 0
              j = 0
              For i = 1 To .Slides.Count
                If .Slides(i).SlideShowTransition.Hidden Then j = j + 1
              Next i:
              For i = 2 To .Slides.Count
                .Slides(i).Shapes("progressBar").Delete
                If .Slides(i).SlideShowTransition.Hidden = msoFalse Then
                   Set slider = .Slides(i).Shapes.AddShape(msoShapeRectangle, 0, sHeight, (i - n) * .PageSetup.SlideWidth / (.Slides.Count - j), 12)
                   With slider
                       .Fill.ForeColor.RGB = ActivePresentation.SlideMaster.ColorScheme.Colors(ppFill).RGB
                       .Name = "progressBar"
                   End With
                Else
                   n = n + 1
                End If
              Next i:
        End With
End Sub

'' Macro to remove the progress bar from all the slides
Sub RemoveProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
              .Slides(i).Shapes("progressBar").Delete
              Next i:
        End With
End Sub

Fantastic and THANK YOU to the programmer.
Is there a way for the bar to start as all the way across and decrease in length towards the right as the slides progress - sort of like a fuse burning down?
Thanks,
Garry34

Hi, just for everyone interested, you may take a look at the version I have on my website (here on github only an old version):
https://datenbank-projekt.de/index.php/beispiele/progress-indicator-powerpoint-2010-2013-2016-32-and-64-bit-windows-and-mac-os

Looks like this

(if the image is missing, just come visit the page and download)
It's free, includes source code and works on Win and MAC

Olaf

Haha if only I saw your comment sooner, seems to be able to generate what I wanted!
I created this one by forking this:

To be found here:
https://gist.github.com/OkkeHendriks/c8d8a5fe71201cc59cbf190e4b8e4f78#file-ppt-progress-bar-circles-vbs