PPT VBA 加页码/总页码的比例进度条

etkane

公司电脑用不了其他工具，代码改哪里可以参考另一个帖子，还是比较简单的。
这个也是搬运加根据需要进行了改造，搬运的地址我实在不好找了，作者发现留个信息，我将备注。

[Visual Basic] 纯文本查看 复制代码

Sub ProgressBar()

    Dim mySlides As Slides
    Dim pageBar As ShapeRange
    Dim pageSHower As Shape
    Dim pageWidth, pageHeight, pageStep
    Dim MyArray() As Variant  '增加一个数组以便统计隐藏的幻灯片
    Dim i, j, k
    j = 0
    k = 0



    
    Set mySlides = Application.ActivePresentation.Slides

    pageWidth = Application.ActivePresentation.SlideMaster.Width
    pageHeight = Application.ActivePresentation.SlideMaster.Height
    ' pageStep = pageWidth / mySlides.Count

    ReDim MyArray(mySlides.Count, 0)
      On Error Resume Next
    For i = 1 To mySlides.Count '统计隐藏的幻灯片数
        ActivePresentation.Slides(i).Shapes("进度条").Delete '删除老的
        If mySlides.Item(i).SlideShowTransition.Hidden = True Then
            j = j + 1
            MyArray(i, 0) = 1
        Else
            MyArray(i, 0) = 0
        End If
    Next

    '除去首页和隐藏的幻灯片后计算进度条长度增量
    If mySlides.Count - 2 - j > 0 Then
        pageStep = (pageWidth - 60) / (mySlides.Count - 3 - j)
    Else
        pageStep = 0
    End If

    On Error Resume Next

    For i = 3 To mySlides.Count - 1  ' 改为从1开始
        k = k + MyArray(i, 0)      ' 计算当前隐藏的幻灯片数
        Set pageBar = mySlides.Item(i).Shapes.Range(Array())
        Set pageBar = _
           mySlides.Item(i).Shapes.Range(Array("进度条"))
        
        If IsNull(pageBar) Or pageBar.Count = 0 Then GoTo newBar
        Set pageSHower = pageBar.Item(1)
        GoTo nextPage

newBar:
        Set pageSHower = mySlides.Item(i).Shapes.AddShape( _
                           msoShapeRectangle, 0, _
                           pageHeight - 3, i * pageStep, 3)
        pageSHower.Name = "进度条"

nextPage:
        pageSHower.Fill.ForeColor.RGB = RGB(187, 222, 251)
        pageSHower.Line.Visible = msoFalse
        ' pageSHower.Width = i * pageStep
        ' 计算进度条长度时除去首页和隐藏的幻灯片
        pageSHower.Width = (i - 2 - k) * pageStep
        pageSHower.Top = pageHeight - 3
        pageSHower.Left = 0
        pageSHower.Height = 3
        ' 删除首页和隐藏的幻灯片的进度条
        If i = 1 Or MyArray(i, 0) = 1 Then pageSHower.Delete
    Next
End Sub

jiujiukeji

etkane 发表于 2024-8-20 11:18
用PPT里的宏

主要是 没看出有啥效果  在宏里执行了  不知道是没效果  还是没执行

lzspain

感谢大佬分享，学习了！office的VBA功能确实强，只是某些批处理感觉比C还是要慢一点。

1270698424

大佬  这个怎么用啊

firethunder

谢谢大佬分享！！

LuckyClover

感谢分享，测试一下怎么样

jiujiukeji

~不会用~~~~~~~~~~~

canghaisui

谢谢大佬分享，能把用法普及一下吗，方便小白

agion

谢谢大佬

etkane

jiujiukeji 发表于 2024-8-19 13:56
~不会用~~~~~~~~~~~

用PPT里的宏