PDA

View Full Version : [SOLVED:] Progress Bar Macro - Help Need from Experts


pacosalasv
09-22-2020, 10:12 AM
ello Macro Masters!

I have a Macro Code to insert a Progress Bar (Copy Paste & Resize an image) in PowerPoint presentation skipping pre-programmed slides (First 2 and Last 2). I need help with two things:

1. Automatically Skip Hidden Slides (Do not include Progress bar) and keep Bar Size based on Applicable Slides
2. Input Box to type Slides to Ignore (Do not apply progress Bar - Skip Slides) when macro its executed.

PowerPoint Macro File: https://drive.google.com/file/d/1bon...ew?usp=sharing (https://drive.google.com/file/d/1bonPqrihDF3stEzL1C8ETQFz71cONZvu/view?usp=sharing)

Here is the Macro Code Allocated in Module 1




Sub ProgressBar()


Dim Width As Integer
Dim MinSize As Integer

ActivePresentation.Slides(1).Shapes("_ProgressBar").Visible = msoFalse
ActivePresentation.Slides(1).Shapes("_ProgressBar").Copy


On Error Resume Next

For Each Sld In ActivePresentation.Slides

For i = Sld.Shapes.Count To 1 Step -1

If Sld.Shapes(i).Name = ("_ProgressBar") Then Sld.Shapes(i).Delete

Next i

Next Sld


scount = ActivePresentation.Slides.Count

On Error Resume Next

If ActivePresentation.Slides(2).Shapes(2).Name = "_PresentationIndex" Then

For j = 3 To scount - 2

ActivePresentation.Slides(j).Shapes.Paste
ActivePresentation.Slides(j).Shapes("_ProgressBar").Visible = msoTrue

Next j

Width = Application.ActivePresentation.PageSetup.SlideWidth

MinSize = Width / scount 'Determine the min size of Progress Bar

For j = 3 To scount - 3

ActivePresentation.Slides(j).Shapes("_ProgressBar").Width = MinSize * j 'Bar Re-Size based on quantity of slides.

Next j

Else

For j = 2 To scount - 2

ActivePresentation.Slides(j).Shapes.Paste
ActivePresentation.Slides(j).Shapes("_ProgressBar").Visible = msoTrue

Next j

Width = Application.ActivePresentation.PageSetup.SlideWidth

MinSize = Width / scount 'Determine the min size of Progress Bar

For j = 2 To scount - 2

ActivePresentation.Slides(j).Shapes("_ProgressBar").Width = MinSize * j 'Bar Re-Size based on quantity of slides.

Next j

'Delete bar from "Thanks!" Page

If ActivePresentation.Slides(j).Shapes("_Thanks") = True Then

ActivePresentation.Slides(j).Shapes("_ProgressBar").Delete

End If

End If


ActivePresentation.Slides(1).Shapes.Paste
ActivePresentation.Slides(1).Shapes("_ProgressBar").Visible = msoFalse


End Sub
Paul_Hossler
09-24-2020, 10:20 AM
I copied a bunch of your slides to have more to test with so the textbox comments are out of date


Slide 1, 2, Las, and next to last - marked with circle-X so no PB

Slides 5, 10, 15,20, and 25 are hidden - marked with circle-X so no PB

To test the 'manual input' I used slides 4, 9, 14, and 19 - marked with circle-X so no PB




Option Explicit

Sub ProgressBar()
Dim oPres As Presentation
Dim oSlide As Slide
Dim i As Long, j As Long

Dim sInput As String
Dim arySkip() As Long, aryAdd() As Long, n1 As Long, n2 As Long

Set oPres = ActivePresentation

'skip first 2 and last 2
ReDim arySkip(1 To 4)
arySkip(1) = 1
arySkip(2) = 2
arySkip(3) = oPres.Slides.Count - 1
arySkip(4) = oPres.Slides.Count

'get manual slide to ignore and put into arySkip
n1 = UBound(arySkip)
n2 = 0
Do While True
sInput = InputBox("Enter a slide to ignore, blank when done", "Ignore Slides")
If Len(sInput) > 0 Then
n1 = n1 + 1
ReDim Preserve arySkip(1 To n1)
arySkip(n1) = CLng(sInput)
Else
Exit Do
End If
Loop

'build array of slides to add PB to in aryAdd
For Each oSlide In ActivePresentation.Slides
If UBound(arySkip) > 0 Then
For i = LBound(arySkip) To UBound(arySkip)
If arySkip(i) = oSlide.SlideNumber Then GoTo NextSlide
Next i
End If

If oSlide.SlideShowTransition.Hidden Then GoTo NextSlide

n2 = n2 + 1
ReDim Preserve aryAdd(1 To n2)
aryAdd(n2) = oSlide.SlideNumber

NextSlide:
Next oSlide

'delete any existing PB except on slide 1 to copy
For Each oSlide In ActivePresentation.Slides
If oSlide.SlideNumber <> 1 Then
For i = oSlide.Shapes.Count To 1 Step -1
If oSlide.Shapes(i).Name = ("_ProgressBar") Then oSlide.Shapes(i).Delete
Next i
End If
Next oSlide

'no slide gets PB
If n2 = 0 Then Exit Sub

'copy PB on slide 1
With oPres
For i = LBound(aryAdd) To UBound(aryAdd)
.Slides(1).Shapes("_ProgressBar").Duplicate
.Slides(aryAdd(i)).Shapes.Paste
.Slides(aryAdd(i)).Shapes("_ProgressBar").Visible = msoTrue
'Bar Re-Size based on quantity of slides.
.Slides(aryAdd(i)).Shapes("_ProgressBar").Width = i * oPres.PageSetup.SlideWidth / UBound(aryAdd)
Next i
End With


End Sub
pacosalasv
09-25-2020, 10:11 AM
WOW! Works Flawless and its awesome, thanks a lot for sharing the code + PowerPoint File.

It does exactly what i need. :clap:


I copied a bunch of your slides to have more to test with so the textbox comments are out of date


Slide 1, 2, Las, and next to last - marked with circle-X so no PB

Slides 5, 10, 15,20, and 25 are hidden - marked with circle-X so no PB

To test the 'manual input' I used slides 4, 9, 14, and 19 - marked with circle-X so no PB






Option Explicit

Sub ProgressBar()
Dim oPres As Presentation
Dim oSlide As Slide
Dim i As Long, j As Long

Dim sInput As String
Dim arySkip() As Long, aryAdd() As Long, n1 As Long, n2 As Long

Set oPres = ActivePresentation

'skip first 2 and last 2
ReDim arySkip(1 To 4)
arySkip(1) = 1
arySkip(2) = 2
arySkip(3) = oPres.Slides.Count - 1
arySkip(4) = oPres.Slides.Count

'get manual slide to ignore and put into arySkip
n1 = UBound(arySkip)
n2 = 0
Do While True
sInput = InputBox("Enter a slide to ignore, blank when done", "Ignore Slides")
If Len(sInput) > 0 Then
n1 = n1 + 1
ReDim Preserve arySkip(1 To n1)
arySkip(n1) = CLng(sInput)
Else
Exit Do
End If
Loop

'build array of slides to add PB to in aryAdd
For Each oSlide In ActivePresentation.Slides
If UBound(arySkip) > 0 Then
For i = LBound(arySkip) To UBound(arySkip)
If arySkip(i) = oSlide.SlideNumber Then GoTo NextSlide
Next i
End If

If oSlide.SlideShowTransition.Hidden Then GoTo NextSlide

n2 = n2 + 1
ReDim Preserve aryAdd(1 To n2)
aryAdd(n2) = oSlide.SlideNumber

NextSlide:
Next oSlide

'delete any existing PB except on slide 1 to copy
For Each oSlide In ActivePresentation.Slides
If oSlide.SlideNumber <> 1 Then
For i = oSlide.Shapes.Count To 1 Step -1
If oSlide.Shapes(i).Name = ("_ProgressBar") Then oSlide.Shapes(i).Delete
Next i
End If
Next oSlide

'no slide gets PB
If n2 = 0 Then Exit Sub

'copy PB on slide 1
With oPres
.Slides(1).Shapes("_ProgressBar").Visible = msoFalse
.Slides(1).Shapes("_ProgressBar").Copy

For i = LBound(aryAdd) To UBound(aryAdd)
.Slides(1).Shapes("_ProgressBar").Duplicate
.Slides(aryAdd(i)).Shapes.Paste
.Slides(aryAdd(i)).Shapes("_ProgressBar").Visible = msoTrue
'Bar Re-Size based on quantity of slides.
.Slides(aryAdd(i)).Shapes("_ProgressBar").Width = i * oPres.PageSetup.SlideWidth / UBound(aryAdd)
Next i
End With


End Sub





Topic can be change to CLOSE!
Paul_Hossler
09-25-2020, 04:40 PM
If you go to [Thread Tools] above your first post, you can select [SOLVED]

BTW, you can remove these two lines - when I was cleaning up. I missed them




.Slides(1).Shapes("_ProgressBar").Visible = msoFalse
.Slides(1).Shapes("_ProgressBar").Copy