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
What I expect
CodePudding user response：
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