幻灯片母版上的 Powerpoint 编号计数器，在每张幻灯片上都继续答案

【问题标题】：Powerpoint Number Counter on the slide master that continues across everyslide幻灯片母版上的 Powerpoint 编号计数器，在每张幻灯片上都继续
【发布时间】：2012-10-03 14:31:04
【问题描述】：

我试图在 MS Powerpoint 中实现的是一个数字计数器，它可以计数到预先确定的数字，即在多张幻灯片上从 1 到 1000，如果在幻灯片放映结束之前由于过度运行，它只会在演讲结束的幻灯片上显示 1000。

到目前为止，我发现了一些从 60 倒数到 0 的代码，但仅在一张幻灯片上，我试图以此为基础，但由于我缺乏对 VBA 和 powerpoint 的理解，到目前为止还没有运气。

任何帮助将不胜感激。

下面是倒计时代码，仅适用于下面一张幻灯片：

Sub Time_Me2()
Dim oshp As Shape
 Dim oshpRng As ShapeRange
 Dim osld As Slide
 Dim oeff As Effect
 Dim i As Integer
 Dim Iduration As Integer
 Dim Istep As Integer
 Dim texttoshow As String
 On Error GoTo errhandler
 If ActiveWindow.Selection.ShapeRange.Count > 1 Then
 MsgBox "Please just select ONE shape!"
 Exit Sub
 End If
 Set osld = ActiveWindow.Selection.SlideRange (1)
 Set oshp = ActiveWindow.Selection.ShapeRange(1)

  oshp.Copy

 'change to suit
 Istep = 1
 Iduration = 60 'in seconds

 For i = Iduration To 0 Step -Istep
 Set oshpRng = osld.Shapes.Paste
 With oshpRng
 .Left = oshp.Left
 .Top = oshp.Top
 End With
 texttoshow = CStr(i)
 oshpRng(1).TextFrame.TextRange = texttoshow
 Set oeff = osld.TimeLine.MainSequence _
 .AddEffect(oshpRng(1), msoAnimEffectFlashOnce, , msoAnimTriggerAfterPrevious)
 oeff.Timing.Duration = Istep
 Next i
 oshp.Delete
 Exit Sub
errhandler:
 MsgBox Err.Description
 End Sub

任何帮助都会很棒！

【问题讨论】：

标签： numbers powerpoint counter

【解决方案1】：

这假设您在幻灯片 1 上添加了一个文本框或其他形状，按照您想要的方式进行格式化，并在运行代码之前选择它。此外，编辑它以将 lMaxCount 设置为 1000 或您希望它“坚持”的任何数字。

Sub NumberSlides()
    Dim oSl As Slide
    Dim oSh As Shape
    Dim oOriginalShape As Shape
    Dim x As Long
    Dim lMaxCount As Long

    ' edit to suit
    lMaxCount = 5

    ' is something selected?
    If Not ActiveWindow.Selection.Type = ppSelectionShapes Then
        MsgBox "Please select one and only one shape on Slide 1"
        Exit Sub
    End If
    ' is only ONE shape selected?
    If Not ActiveWindow.Selection.ShapeRange.Count = 1 Then
        MsgBox "Please select one and only one shape on Slide 1"
        Exit Sub
    End If
    ' is the selected shape on the first slide?
    If Not ActiveWindow.Selection.ShapeRange(1).Parent.SlideIndex = 1 Then
        MsgBox "Please select one and only one shape on Slide 1"
        Exit Sub
    End If

    Set oOriginalShape = ActiveWindow.Selection.ShapeRange(1)

    For x = 2 To ActivePresentation.Slides.Count
        Set oSl = ActivePresentation.Slides(x)
        oOriginalShape.Copy
        Set oSh = oSl.Shapes.Paste(1)
        If x > lMaxCount Then
            oSh.TextFrame.TextRange.Text = CStr(lMaxCount)
        Else
            oSh.TextFrame.TextRange.Text = CStr(x)
        End If
    Next

End Sub

【讨论】：