|
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 |
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:
If it is too much trouble, no worries.
Thanks again,
Chris