Search code examples
vbaprogress-barpowerpoint

how to update fill object loop in powerpoint vba

I would like to modify a macro I took on the internet to make a progress bar with a slide group in power point. But instead of having a vertical gradient motion, I want to fill the object as a progess bar. I am totally new to vba and I don’t understand how it works . Thank you

Sub BarreDeProgression()
'Génère une barre de progression

'Valeurs à adapter selon besoin
Const Longueur As Single = 0.1    'Longueur totale de la barre (% de  la longueur de la diapo (0.25 =25%))
Const Hauteur As Single = 0.03     'Hauteur totale de la barre (% de  la hauteur de la diapo)
Const PositionX As Single = 0     'Position en X de la barre (% de  la longueur de la diapo en partant de la gauche)
Const PositionY As Single = 0.985   'Position en Y de la barre (% de  la hauteur de la diapo en partant de la gauche)


'Récupération des infos
Set Pres = ActivePresentation
H = Pres.PageSetup.SlideHeight
W = Pres.PageSetup.SlideWidth * Longueur
nb = Pres.Slides.Count
Counter = 1
Counter2 = 1
nbgroupe = 5 'CInt(InputBox("nombre de groupe ?", "nombre de groupe", 1))
Dim Tabgroup() As Integer
Dim a As Integer
Dim X As Integer
a = 0
Dim test As Integer
test = 0

'nombre de page pour chaque groupe
For L = 1 To nbgroupe
    ReDim Preserve Tabgroup(2, 1 To L)
    nbslide = 3 'CInt(InputBox("nombre de slide dans le groupe" & L & " ?", "nombre de slide du groupe", 1))
    Tabgroup(0, L) = nbslide
    Tabgroup(1, L) = nbslide + a
    Tabgroup(2, L) = Tabgroup(1, L) - nbslide
    a = Tabgroup(1, L)
Next

'Pour chaque Slide

For X = 1 To Pres.Slides.Count
    If X > 1 And X < (Pres.Slides.Count) Then

        'Supprime l'ancienne barre de progression
        nbShape = Pres.Slides(X).Shapes.Count
        del = 0
        For a = 1 To nbShape
            If Left(Pres.Slides(X).Shapes.Item(a - del).Name, 2) = "PB" Then
                Pres.Slides(X).Shapes.Item(a - del).Delete
                del = del + 1
            End If
        Next

        'pose la nouvelle barre de progression
        For i = 0 To nbgroupe - 1
            Set OBJ = Pres.Slides(X).Shapes.AddShape(msoShapeChevron, (W * i / nbgroupe) + W / nbgroupe * (PositionX / 2), H * (1 - PositionY), (W / nbgroupe) * (1 - PositionX), H * Hauteur)
            OBJ.Name = "PB" & i
            OBJ.Line.Visible = msoFalse
            If Tabgroup(1, i + 1) >= Counter And Counter > test Then
                OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
                OBJ.Fill.TwoColorGradient Style:=msoGradientVertical, Variant:=1
                OBJ.Fill.GradientStops.Insert RGB(156, 156, 156), 0.99
                OBJ.Fill.GradientStops.Insert RGB(156, 156, 156), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - (1 / Tabgroup(0, i + 1))
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - (1 / Tabgroup(0, i + 1)) + 0.02
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - 0.02
                OBJ.Fill.GradientStops.Insert RGB(156, 156, 156), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1))
            Else
                OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
            End If
            test = Tabgroup(1, i + 1)
        Next
        test = 0
        Counter = Counter + 1
       
    End If
Next X
End Sub

This is the result

enter image description here

What I expect

enter image description here

Solution

  • You just needed to add this extra If clause:

    ElseIf Tabgroup(1, i + 1) < Counter Then OBJ.Fill.ForeColor.RGB = RGB(216, 32, 39)

    commented below. I also slightly changed how the color behaves. In case you do not want it this way, just replace as per above.

    

Sub BarreDeProgression()
'Génère une barre de progression

'Valeurs à adapter selon besoin
Const Longueur As Single = 0.1    'Longueur totale de la barre (% de  la longueur de la diapo (0.25 =25%))
Const Hauteur As Single = 0.03     'Hauteur totale de la barre (% de  la hauteur de la diapo)
Const PositionX As Single = 0     'Position en X de la barre (% de  la longueur de la diapo en partant de la gauche)
Const PositionY As Single = 0.985   'Position en Y de la barre (% de  la hauteur de la diapo en partant de la gauche)


'Récupération des infos
Set Pres = ActivePresentation
H = Pres.PageSetup.SlideHeight
W = Pres.PageSetup.SlideWidth * Longueur
nb = Pres.Slides.Count
Counter = 1
Counter2 = 1
nbgroupe = 5 'CInt(InputBox("nombre de groupe ?", "nombre de groupe", 1))
Dim Tabgroup() As Integer
Dim a As Integer
Dim X As Integer
a = 0
Dim test As Integer
test = 0

'nombre de page pour chaque groupe
For L = 1 To nbgroupe
    ReDim Preserve Tabgroup(2, 1 To L)
    nbslide = 3 'CInt(InputBox("nombre de slide dans le groupe" & L & " ?", "nombre de slide du groupe", 1))
    Tabgroup(0, L) = nbslide
    Tabgroup(1, L) = nbslide + a
    Tabgroup(2, L) = Tabgroup(1, L) - nbslide
    a = Tabgroup(1, L)
Next

'Pour chaque Slide

For X = 1 To Pres.Slides.Count
    If X > 1 And X < (Pres.Slides.Count) Then

        'Supprime l'ancienne barre de progression
        nbShape = Pres.Slides(X).Shapes.Count
        del = 0
        For a = 1 To nbShape
            If Left(Pres.Slides(X).Shapes.Item(a - del).Name, 2) = "PB" Then
                Pres.Slides(X).Shapes.Item(a - del).Delete
                del = del + 1
            End If
        Next

        'pose la nouvelle barre de progression
        For i = 0 To nbgroupe - 1
            Set OBJ = Pres.Slides(X).Shapes.AddShape(msoShapeChevron, (W * i / nbgroupe) + W / nbgroupe * (PositionX / 2), H * (1 - PositionY), (W / nbgroupe) * (1 - PositionX), H * Hauteur)
            OBJ.Name = "PB" & i
            OBJ.Line.Visible = msoFalse
            If Tabgroup(1, i + 1) >= Counter And Counter > test Then
                OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
                OBJ.Fill.TwoColorGradient Style:=msoGradientVertical, Variant:=1
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), 0
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - (1 / Tabgroup(0, i + 1))
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - (1 / Tabgroup(0, i + 1)) + 0.02
                OBJ.Fill.GradientStops.Insert RGB(216, 32, 39), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1)) - 0.02
                OBJ.Fill.GradientStops.Insert RGB(156, 156, 156), (Counter - Tabgroup(2, i + 1)) * (1 / Tabgroup(0, i + 1))
                OBJ.Fill.GradientStops.Insert RGB(156, 156, 156), 1
            
            ElseIf Tabgroup(1, i + 1) < Counter Then 'here
                OBJ.Fill.ForeColor.RGB = RGB(216, 32, 39)
            
            
            Else
                OBJ.Fill.ForeColor.RGB = RGB(156, 156, 156)
                

            End If
            test = Tabgroup(1, i + 1)
        Next
        test = 0
        Counter = Counter + 1
       
    End If
Next X
End Sub