Powerpoint progress bar with cool style

[arniel01]

Hello everyone, I was wondering if a progress bar or progress indicator intended for Powerpoint slides shows could look cooler.
I found this macro code from another Powerpoint VBA forum. It is exactly what I was looking for to be used in one of my presentations, but for some reason I find it to be more fit if the progress indicator is Circular and with numbers in percent. I was wondering if it is possible to add cooler effects or appearance through powerpoint VBA.

This is the macro code for progress bar:


Sub AddProgressBar()
On Error Resume Next
With ActivePresentation
For X = 1 To .Slides.Count
.Slides(X).Shapes("PB").Delete
Set s = .Slides(X).Shapes.AddShape(msoShapeRectangle, _
0, .PageSetup.SlideHeight - 12, _
X * .PageSetup.SlideWidth / .Slides.Count, 12)
s.Fill.ForeColor.RGB = RGB(127, 0, 0)
s.Name = "PB"
Next X
End With
End Sub

These are the sites where I found circular progress indicator:
The pie-type
http://stackoverflow.com/questions/10782394/pop-up-the-excel-statusbar

The cooler pie type
http://www.scottlogic.com/blog/2011/02/07/a-circular-progressbar-style-using-an-attached-viewmodel.html

[John Wilson]

You could try:


Sub progBar()
Dim lngTotal As Long
Dim lngIndx As Long
Dim osld As Slide
Dim oshp1 As Shape
Dim oshp2 As Shape
Dim otB As Shape

On Error Resume Next
lngTotal = ActivePresentation.Slides.Count
For Each osld In ActivePresentation.Slides
osld.Shapes("Marker1").Delete
osld.Shapes("Marker2").Delete
osld.Shapes("Marker3").Delete
lngIndx = osld.SlideIndex
Set oshp1 = osld.Shapes.AddShape(msoShapePie, 10, ActivePresentation.PageSetup.SlideHeight - 25, 20, 20)

With oshp1
.Fill.ForeColor.RGB = vbGreen
.Line.Visible = False
.Adjustments(1) = -90
.Adjustments(2) = -90
.Name = "Marker1"
End With

If osld.SlideIndex <> lngTotal Then
Set oshp2 = osld.Shapes.AddShape(msoShapePie, 10, ActivePresentation.PageSetup.SlideHeight - 25, 20, 20)

With oshp2
.Fill.ForeColor.RGB = vbRed
.Line.Visible = False
.Adjustments(1) = (360 * (lngIndx / lngTotal)) - 90
.Adjustments(2) = -90
.Name = "Marker2"
End With
End If

Set otB = osld.Shapes.AddLabel(msoTextOrientationHorizontal, 25, ActivePresentation.PageSetup.SlideHeight - 20, 40, 10)

With otB.TextFrame.TextRange
.Font.Size = 8
.Text = Round((lngIndx / lngTotal) * 100, 1) & "%"
End With
otB.Name = "Marker3"
Next osld
End Sub

[arniel01]

You could try:

Sub progBar()
Dim lngTotal As Long
Dim lngIndx As Long
Dim osld As Slide
Dim oshp1 As Shape
Dim oshp2 As Shape
Dim otB As Shape
On Error Resume Next
lngTotal = ActivePresentation.Slides.Count
For Each osld In ActivePresentation.Slides
osld.Shapes("Marker1").Delete
osld.Shapes("Marker2").Delete
osld.Shapes("Marker3").Delete
lngIndx = osld.SlideIndex
Set oshp1 = osld.Shapes.AddShape(msoShapePie, 10, ActivePresentation.PageSetup.SlideHeight - 25, 20, 20)
With oshp1
.Fill.ForeColor.RGB = vbGreen
.Line.Visible = False
.Adjustments(1) = -90
.Adjustments(2) = -90
.Name = "Marker1"
End With
If osld.SlideIndex <> lngTotal Then
Set oshp2 = osld.Shapes.AddShape(msoShapePie, 10, ActivePresentation.PageSetup.SlideHeight - 25, 20, 20)
With oshp2
.Fill.ForeColor.RGB = vbRed
.Line.Visible = False
.Adjustments(1) = (360 * (lngIndx / lngTotal)) - 90
.Adjustments(2) = -90
.Name = "Marker2"
End With
End If
Set otB = osld.Shapes.AddLabel(msoTextOrientationHorizontal, 25, ActivePresentation.PageSetup.SlideHeight - 20, 40, 10)
With otB.TextFrame.TextRange
.Font.Size = 8
.Text = Round((lngIndx / lngTotal) * 100, 1) & "%"
End With
otB.Name = "Marker3"
Next osld
End Sub

Wow! This is really amazing! It was far better than I can think of with PowerPoint VBA.
Thank You So Much Mr. John Wilson. You are the Best! This is really helpful.

[mancubus]

i strongly agree with you arniel. thank you for all your support and your amazing pptalchemy pages John.

[Paul_Hossler]

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

[Paul_Hossler]

@John -- I REALLY like the circles

I have to play with them a bit to make a little smaller, and I have to integrate them into my ribbon (prefer the ribbon to the QAT), but very useful addition

I don't suppose there's any way to make it automatic, regardless of adding and deleting is there?

Paul

[John Wilson]

It's possible but not simple.

Build a With Events AddIn

When the SlideSelection Event fires (It will fire when slides are added or deleted but also when you just select a different slide) compare the actual slide number against a stored value. If it's different update the stored number and fire the routine. It it's the same do nothing. Good exercise for you!!

[Paul_Hossler]

Good exercise for you!!


Yes. I think that the BeforeSave would be better though.

Check to see if there's "Marker1"

Delete the current circles

Add new ones based on the current total of slides and the slide number

Thoughts?

Paul

[John Wilson]

You could, but I had in mind the circles updating everytime you added or deleted a slide in the same way that slide numbers do. If you want the outline code I can send it to you if you contact me, (contact page on pptalchemy.co.uk) I don't want to post it because it's complex and needs some skill (which I know you have).

[databasedev]

Hi

I (re)created a FREE Progress Indicator macro.
The macro can be used with PowerPoint MS-Office 2010 and above (currently 2016), 32 and 64bit versions and on Windows and MAC OS X!

Please check out the documentation and download: ... serious guys, 5 postings to post a link here? I want to help....

Short URL (copy and paste into your address bar, see next reply for unshortened link):
url.olaf-noehring.de/progressindicator


Olaf

[databasedev]

Maybe i can also post the unshortened link:
Long URL
datenbank-projekt.de/index.php/beispiele/progress-indicator-powerpoint-2010-2013-2016-32-and-64-bit-windows-and-mac-os

Olaf