Slightly different way I do it
Adds a thin Blue/Red shape accross the top
Option Explicit
Sub AddProgressBars()
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
Dim iBlueBarLength As Long
Call DeleteProgressBars
Set oPres = ActivePresentation
'make sure there's a presentation
If ActivePresentation Is Nothing Then Exit Sub
If ActivePresentation.Slides.Count < 4 Then Exit Sub
For Each oSlide In oPres.Slides
'add red background
Set oShape = oSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, oPres.PageSetup.SlideWidth - 1, 6)
With oShape
.Name = "ProgressBarRed"
.Line.Weight = 0.5
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Fill.Solid
.Fill.ForeColor.RGB = RGB(255, 0, 0)
End With
'add blue overlay
iBlueBarLength = oPres.PageSetup.SlideWidth * (oSlide.SlideNumber - 1)
iBlueBarLength = iBlueBarLength / (oPres.Slides.Count - 1)
Set oShape = oSlide.Shapes.AddShape(msoShapeRectangle, 0, 0, iBlueBarLength, 6)
With oShape
.Name = "ProgressBarBlue"
.Line.Weight = 0
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Fill.Solid
.Fill.ForeColor.RGB = RGB(0, 0, 255)
End With
Next
End Sub
Sub DeleteProgressBars()
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
'make sure there's a presentation
If ActivePresentation Is Nothing Then Exit Sub
Set oPres = ActivePresentation
For Each oSlide In oPres.Slides
On Error Resume Next
oSlide.Shapes("ProgressBarRed").Delete
oSlide.Shapes("ProgressBarBlue").Delete
On Error GoTo 0
Next
End Sub
Paul