Consulting

Results 1 to 4 of 4

Thread: Progress Bar Macro - Help Need from Experts

  1. #1

    Question Progress Bar Macro - Help Need from Experts

    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

    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

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Attached Files Attached Files
    Last edited by Paul_Hossler; 09-27-2020 at 09:10 AM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    WOW! Works Flawless and its awesome, thanks a lot for sharing the code + PowerPoint File.

    It does exactly what i need.

    Quote Originally Posted by Paul_Hossler View Post
    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!

  4. #4
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,711
    Location
    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
    Last edited by Paul_Hossler; 09-25-2020 at 05:51 PM.
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •