Generate a progress bar for Powerpoint presentations

Generate a progress bar for Powerpoint presentations.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 one of the below files in the blank page:

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 run the RemoveProgressBar macro.

Examples

For examples of the different progress bars see below.

Circles

Simple progress bar

Simple progress bar with numbers

PPT-Progress-Bar-Circles.vbs

Public Const shapeName As String = "ProgressShape"

' Also set the alternative text field, this is checked during clearing such that one can copy a
' shape and change this text in order to re-use the shapes
Public Const shapeAltText As String = "ProgressShape, remove this if you do not want it to be auto cleared"

' Lookup table for the circle colors
Function Color(ByVal index As Integer)
    Color = RGB(0, 0, 0)
    ' Correct for nr of skipped begin slides
    index = index - skipBeginNrSlides
    Select Case index
    Case Is <= 3
        Color = RGB(255, 164, 32)
    Case Is <= 5
        Color = RGB(20, 141, 137)
    Case Is <= 10
        Color = RGB(240, 70, 20)
    Case Is <= 15
        Color = RGB(29, 130, 32)
    Case Is <= 100
        Color = RGB(255, 164, 32)
    End Select

End Function

' Remove all shapes with the circleName name from all slides
Function ClearProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
                Do
                    found = False
                    For Each Shp In .Slides(i).Shapes
                        If Shp.Name = shapeName And Shp.AlternativeText = shapeAltText Then
                            Shp.Delete
                            found = True
                        End If
                    Next Shp
                Loop Until found = False
              Next i:
        End With
End Function

Sub AddProgressCircle()
    ' Always clear first
    ClearProgressBar
    On Error Resume Next
        With ActivePresentation
              
              ' Parameters
              skipBeginNrSlides = 1
              skipEndNrSlides = 0
              totalBarWidth = .PageSetup.SlideWidth / 2#
              circleLineWidth = 0.2
              interCircleDistance = 4#
              distFromRight = 12.5
              distFromBottom = 12.5
              
              'Count nr visible
              nrVisible = 0
              For i = 1 To .Slides.Count
                If .Slides(i).SlideShowTransition.Hidden = msoFalse Then nrVisible = nrVisible + 1
              Next i:
              
              ' Calculated parameters
              nrProgress = nrVisible - skipBeginNrSlides - skipEndNrSlides
              interCircleDistanceSum = interCircleDistance * nrProgress
              circleSize = (totalBarWidth - interCircleDistanceSum) / nrProgress
              widthPerCirclePlusSpacing = circleSize + interCircleDistance
              startX = .PageSetup.SlideWidth - circleSize - totalBarWidth - distFromRight
              startY = .PageSetup.SlideHeight - circleSize - distFromBottom
              
              ' Draw the progress bar
              n = 0
              ' Loop through all slides
              For i = 1 To .Slides.Count
                ' Draw circles when current slide is not hidden and total number of circles have not yet been drawn
                If .Slides(i).SlideShowTransition.Hidden = msoFalse And n < nrProgress + skipBeginNrSlides Then
                    ' Keep track of current progress, i.e. nr of visible slides
                    n = n + 1
                    If n <= skipBeginNrSlides Then GoTo ContinueLoop
                    
                    ' Loop through all the progress circles for the slide
                    For k = 1 To nrProgress
                        ' Vary the x position based on the circle size and the inter circle distance
                        x = startX + (k * widthPerCirclePlusSpacing)
                        
                        ' Determine the color via the lookup table
                        currentColor = Color(k)
                        
                        ' Draw circle outlines
                        Set totProgCircle = .Slides(i).Shapes.AddShape(msoShapeOval, x, startY, circleSize, circleSize)
                        With totProgCircle
                          .Fill.ForeColor.RGB = RGB(255, 255, 255)
                          .Line.Visible = msoTrue
                          .Line.ForeColor.RGB = currentColor
                          .Line.Weight = circleLineWidth
                          .Name = shapeName
                          .AlternativeText = shapeAltText
                        End With
 
                        ' Draw half filled in circle for current slide
                        If k = n - skipBeginNrSlides Then
                            halfCircleSize = (circleSize / 2#)
                            fourthCircleSize = (circleSize / 4#)
                            Set totProgCircle = .Slides(i).Shapes.AddShape(msoShapeOval, x + fourthCircleSize, startY + fourthCircleSize, halfCircleSize, halfCircleSize)
                            With totProgCircle
                              .Fill.ForeColor.RGB = currentColor
                              .Line.Visible = msoTrue
                              .Line.ForeColor.RGB = currentColor
                              .Line.Weight = circleLineWidth
                              .Name = shapeName
                              .AlternativeText = shapeAltText
                            End With
                        ' Draw filled in circle for past slides
                        ElseIf k <= n - skipBeginNrSlides Then
                            Set totProgCircle = .Slides(i).Shapes.AddShape(msoShapeOval, x, startY, circleSize, circleSize)
                            With totProgCircle
                              .Fill.ForeColor.RGB = currentColor
                              .Line.Visible = msoTrue
                              .Line.ForeColor.RGB = currentColor
                              .Line.Weight = circleLineWidth
                              .Name = shapeName
                              .AlternativeText = shapeAltText
                            End With
                        End If
                        
                        
                    Next k:
                End If
ContinueLoop:
              Next i:
        End With
End Sub

Sub RemProgressCircle()
    ClearProgressBar
End Sub

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

Public Const shapeName As String = "ProgressShape"

' Also set the alternative text field, this is checked during clearing such that one can copy a
' shape and change this text in order to re-use the shapes
Public Const shapeAltText As String = "ProgressShape, remove this if you do not want it to be auto cleared"

' Remove all shapes with the circleName name from all slides
Function ClearProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
                Do
                    found = False
                    For Each Shp In .Slides(i).Shapes
                    If Shp.Name = shapeName And Shp.AlternativeText = shapeAltText Then
                            Shp.Delete
                            found = True
                        End If
                    Next Shp
                Loop Until found = False
              Next i:
        End With
End Function

'' Add progress bar and page numbers to all non-hidden pages
Sub AddProgressBar()
    ClearProgressBar
    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
                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 = shapeName
                      .AlternativeText = shapeAltText
                  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 = shapeName
                       .AlternativeText = shapeAltText
                   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()
    ClearProgressBar
End Sub

PPT-Progress-Bar.vbs

Public Const shapeName As String = "ProgressShape"

' Also set the alternative text field, this is checked during clearing such that one can copy a
' shape and change this text in order to re-use the shapes
Public Const shapeAltText As String = "ProgressShape, remove this if you do not want it to be auto cleared"

' Remove all shapes with the circleName name from all slides
Function ClearProgressBar()
    On Error Resume Next
        With ActivePresentation
              For i = 1 To .Slides.Count
                Do
                    found = False
                    For Each Shp In .Slides(i).Shapes
                        If Shp.Name = shapeAltText And Shp.AlternativeText = shapeAltText Then
                            Shp.Delete
                            found = True
                        End If
                    Next Shp
                Loop Until found = False
              Next i:
        End With
End Function

'' Add progress bar only to all non-hidden pages
Sub AddProgressBar()
    ClearProgressBar
    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 = shapeName
                       .AlternativeText = shapeAltText
                   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()
    ClearProgressBar
End Sub

@OkkeHendriks I really like your progress bar circles. How can edit the parameters that the progress circles match the number of slides for the particular section. How are the number of circles and colors determined? Thanks in advance

Thanks :)!

This is done through the color function, basically a lookup table, at line 8. By changing or adding indexes in the select statement at line 12 you can change the number of circles of each color. Good luck, happy to answer more questions if not yet clear!

Thanks a lot for quick reply. I completely new to VBA so I do have another question. What would the code look like if I have the following:

• a) title slide (n=1 slide - no circles)
• b) agenda (n=2 slides - no circles)
• c) agenda point 1 (n=3-5 slides - circles)
• d) agenda (n=6 slide - no circles)
• e) agenda point 2 (n=7 - 23 slides - circles)

If it is too much trouble, no worries.

Thanks again,
Chris