パワポにプログレスバーを追加するマクロ

MakeSlideProgressLine.bas

Function hex2rgb(HexColor As String) As Long
    'HEX表記をRGB値に変換する
    Color = Replace(HexColor, "#", "")
    Red = CInt("&H" & Mid(Color, 1, 2))
    Green = CInt("&H" & Mid(Color, 3, 2))
    Blue = CInt("&H" & Mid(Color, 5, 2))
    hex2rgb = RGB(Red, Green, Blue)
End Function
Function Reset()
    With ActivePresentation
        'スライド中にProgressBarがあれば消す
        For Each s In .Slides
            For Each sh In s.Shapes
                If UCase(sh.Name) = UCase("ProgressBar") Then
                    sh.Delete
                End If
            Next sh
        Next s
        
        'スライドマスターにProgressBarBGがあれば消す
        For Each sh In .SlideMaster.Shapes
            If UCase(sh.Name) = UCase("ProgressBarBG") Then
                sh.Delete
            End If
        Next sh
    End With
End Function
Sub MakeSlideProgressLine()
    Const pgBGColor As String = "#2F3045"
    Const pgColor As String = "#33C361"
    
    '過去に追加したプログレスバーを削除
    Reset
 
    '非表示スライドは， プログレスに含めない
    Dim length As Integer
    With ActivePresentation
        '表示スライド枚数を数える
        For Each s In .Slides
            If s.SlideShowTransition.Hidden = msoFalse Then
                length = length + 1
            End If
        Next s

        '背景バーの追加
        Set sh = .SlideMaster.Shapes.AddLine(0, 0, .PageSetup.SlideWidth, 0)
        With sh
            .Line.ForeColor.RGB = hex2rgb(pgBGColor)
            .Name = "ProgressBarBG"
        End With

        '表示スライドに プログレスバーを追加
        For i = 1 To length
            Set sh = .Slides(i).Shapes.AddLine(0, 0, i * .PageSetup.SlideWidth / length, 0)
            With sh
                .Line.ForeColor.RGB = hex2rgb(pgColor)
                .Name = "ProgressBar"
            End With
        Next i
    End With
End Sub