为PPT添加进度条

PPT页数多的时候，总等不到演讲者结束。自己反过来想，我的PPT必须每次添加进度条，让听的人心里有个数，到底ta还要忍受多少页PPT才能离开。
自己新建了一个PPT模板，添加了多个主题，填了VBA代码，保存为potm后缀的模板文件。每次编辑完PPT后，到开发工具->宏，点击运行一次就好了。

Sub AddProgressBar()
 On Error Resume Next
  '当前PPT文件
  With ActivePresentation 
    'iterate through slides
    '每一张幻灯片都要加
    For X = 1 To .Slides.count 
        'delete them if shapes PB and PBtag exist
        '把已有的shape都删掉，旧的
        .Slides(X).Shapes("PB").Delete
        .Slides(X).Shapes("PBTag").Delete
       '跳过第一章幻灯片，也就是第一张不加进度条
        If X = 1 Then
           GoTo NextLoop
        End If
        '_ is next line combiner
        '开始计算页数，百分比，这些性状需要放的位置
        Dim margin As Double, width As Double, count As Integer, curPos As Double, curRatio As Double
        count = .Slides.count
        margin = 35.64 
        'the distance between the left border of Slide and this object
        '设定进度条里两边的距离
        width = .PageSetup.SlideWidth - (margin * 2) 'full width of PB
        '得到进度条的最大宽度，也就是最后一页的长度，100%
        curPos = X * width / count 'width of PB per Slide
        '获取当前幻灯片的进度条长度
        curRatio = Round(X / count, 4) * 100 
        'percentage  of current Slide
        '获得当前幻灯片的进度百分比
        'Add corner-rounded rectangle
        Set bar = .Slides(X).Shapes.AddShape(msoShapeRoundedRectangle, margin, -2, curPos, 3)
        ' bar就是当前页面进度条对象
        'font color and Name of PB
        '设置条的阴影效果
        With bar.Shadow
            .Blur = 6
            .OffsetX = 1
            .OffsetY = 2
            .ForeColor.RGB = RGB(100, 100, 100)
        End With
        '设置对象的名字，和背景色
        With bar
            .Name = "PB"
            .Fill.ForeColor.RGB = RGB(252, 255, 2)
        End With
        'border style of PB
        '去掉边框
        With bar.Line
          .Visible = msoFalse
        End With
        
        'XXXXXXXXXXXXXXXX
        'Add PBTag Shape
        'XXXXXXXXXXXXXXXX
        ' 数字显示的标记的对象bartag
        Set bartag = .Slides(X).Shapes.AddShape(msoShapeCloud, curPos + 9.89, 3, 62.9, 22.44)
        With bartag
            '.Rotation = 180 '不行字也会倒过来
            .TextFrame.TextRange = X & "/" & count
            .Name = "PBTag"
            ' 背景色
            With .Fill
                .ForeColor.RGB = RGB(252, 255, 2)
            End With
             '设置字体效果
            With .TextFrame.TextRange.Font
                .Size = 13
                .Name = "Yu Gothic UI"
                .Bold = msoTrue
                .Color.RGB = RGB(100, 100, 100)
                .HorizontalAlignment = msoAnchorCenter
            End With
            '添加阴影效果
            With .Shadow
                .Blur = 6
                .OffsetX = 1
                .OffsetY = 2
                .ForeColor.RGB = RGB(100, 100, 100)
            End With
            '去掉边框
            With .Line
                .Weight = 0.5
                .ForeColor.RGB = RGB(255, 235, 50)
            End With
        End With
NextLoop:
    Next X:
  End With
End Sub

Resultant Display

不足

1. PBTag的位置需要依据页数的多少，以及字体，字体的大小等，自己设置，也就是下面的，参数2和4

     (msoShapeCloud, curPos + 9.89, 3, 62.9, 22.44)
   

2. 如果需要显示百分比

   .TextFrame.TextRange = X & "/" & count
   

   改成下面的就可以了

   .TextFrame.TextRange = curRatio
   

引用

1. PowerPoint VBA reference | MSDN