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/1...xcel-statusbar

The cooler pie type
http://www.scottlogic.com/blog/2011/...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