How to inserte progress DOTS in powerpoint 2012

[Paul_Hossler]

Percentage markers


[vba]
Sub AddMarkers_1()
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape
Dim aBox(0 To 9) As Shape
Dim i As Long, iDots As Long
Dim dblPercent As Double
Set oPres = ActivePresentation
For Each oSlide In oPres.Slides
For i = LBound(aBox) To UBound(aBox)
On Error Resume Next
oSlide.Shapes("Box" & i).Delete
On Error GoTo 0

Set aBox(i) = oSlide.Shapes.AddShape(msoShapeRectangle, 12 * i, 0, 12, 12)
aBox(i).Name = "Box" & i
aBox(i).Fill.ForeColor.RGB = RGB(0, 0, 0)
aBox(i).Line.Weight = 1
aBox(i).Line.ForeColor.RGB = RGB(255, 255, 255)
Next i
Next

For Each oSlide In oPres.Slides
dblPercent = 100# * oSlide.SlideNumber / oPres.Slides.Count

If dblPercent < 5# Then
iDots = -1
ElseIf dblPercent < 15# Then
iDots = 0
ElseIf dblPercent < 25# Then
iDots = 1
ElseIf dblPercent < 35# Then
iDots = 2
ElseIf dblPercent < 45# Then
iDots = 3
ElseIf dblPercent < 55# Then
iDots = 4
ElseIf dblPercent < 65# Then
iDots = 5
ElseIf dblPercent < 75# Then
iDots = 6
ElseIf dblPercent < 85# Then
iDots = 7
ElseIf dblPercent < 95# Then
iDots = 8
Else
iDots = 9
End If

For i = 0 To iDots
oSlide.Shapes("Box" & i).Fill.ForeColor.RGB = RGB(255, 0, 0)
Next i
Next

MsgBox "Done adding progress dots"
End Sub
[/vba]