如何修改PowerPoint VBA进度条宏：替换垂直渐变为填充式进度

我从网上获取了一个PowerPoint进度条宏，它能基于幻灯片组生成进度条，但当前呈现的是垂直渐变效果。我希望将其修改为填充式进度条，作为VBA新手我看不懂代码逻辑，恳请帮忙修改。

原代码 #

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

效果对比 #

当前效果：

期望效果：

修改后的代码 #

Sub BarreDeProgression_FillStyle()
'生成填充式进度条

'可调整参数
Const Longueur As Single = 0.1    '进度条总长度（占幻灯片宽度的比例，0.25=25%）
Const Hauteur As Single = 0.03     '进度条高度（占幻灯片高度的比例）
Const PositionX As Single = 0     '进度条X轴起始位置（占幻灯片宽度的比例，从左开始）
Const PositionY As Single = 0.985   '进度条Y轴起始位置（占幻灯片高度的比例，从下开始）
Const CouleurFond As Long = RGB(156, 156, 156) '进度条背景色
Const CouleurRemplissage As Long = RGB(216, 32, 39) '填充色

'获取演示文稿信息
Set Pres = ActivePresentation
H = Pres.PageSetup.SlideHeight
W = Pres.PageSetup.SlideWidth * Longueur
nb = Pres.Slides.Count
Counter = 1
nbgroupe = 5 '可改为输入框：CInt(InputBox("输入分组数？", "分组数", 1))
Dim Tabgroup() As Integer
Dim a As Integer
Dim X As Integer
a = 0
Dim test As Integer
test = 0

'定义每组幻灯片数量
For L = 1 To nbgroupe
    ReDim Preserve Tabgroup(2, 1 To L)
    nbslide = 3 '可改为输入框：CInt(InputBox("输入第" & L & "组的幻灯片数？", "组内幻灯片数", 1))
    Tabgroup(0, L) = nbslide
    Tabgroup(1, L) = nbslide + a
    Tabgroup(2, L) = Tabgroup(1, L) - nbslide
    a = Tabgroup(1, L)
Next

'遍历每张幻灯片
For X = 1 To Pres.Slides.Count
    If X > 1 And X < Pres.Slides.Count Then

        '删除旧的进度条
        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

        '生成新的填充式进度条
        For i = 0 To nbgroupe - 1
            '1. 添加灰色背景条
            Dim bgBar As Shape
            Set bgBar = Pres.Slides(X).Shapes.AddShape(msoShapeRectangle, _
                (W * i / nbgroupe) + W / nbgroupe * (PositionX / 2), _
                H * (1 - PositionY), _
                (W / nbgroupe) * (1 - PositionX), _
                H * Hauteur)
            bgBar.Name = "PB_bg" & i
            bgBar.Line.Visible = msoFalse
            bgBar.Fill.ForeColor.RGB = CouleurFond

            '2. 根据进度添加红色填充条
            If Tabgroup(1, i + 1) >= Counter And Counter > test Then
                Dim fillRatio As Single
                '计算当前幻灯片在组内的进度比例
                fillRatio = (Counter - Tabgroup(2, i + 1)) / Tabgroup(0, i + 1)
                '避免比例超过1
                If fillRatio > 1 Then fillRatio = 1

                Dim fillBar As Shape
                Set fillBar = Pres.Slides(X).Shapes.AddShape(msoShapeRectangle, _
                    bgBar.Left, _
                    bgBar.Top, _
                    bgBar.Width * fillRatio, _
                    bgBar.Height)
                fillBar.Name = "PB_fill" & i
                fillBar.Line.Visible = msoFalse
                fillBar.Fill.ForeColor.RGB = CouleurRemplissage
            End If
            test = Tabgroup(1, i + 1)
        Next
        test = 0
        Counter = Counter + 1
       
    End If
Next X
End Sub

关键修改说明 #

• 替换原代码的渐变填充逻辑，改为双层矩形结构：底层灰色背景条，上层红色填充条，通过调整上层条的宽度实现填充效果
• 将原有的msoShapeChevron（箭头形状）改为msoShapeRectangle（矩形），更贴合进度条的视觉需求
• 提取颜色参数为常量，方便后续快速调整
• 简化进度计算逻辑，直接根据当前幻灯片在组内的位置计算填充比例，逻辑更直观

内容的提问来源于stack exchange，提问作者Salim S