1

私が MS Powerpoint で達成しようとしているのは、多数のスライドにわたって 1 から 1000 までの所定の数までカウントする数カウンターであり、オーバーランのためにスライド ショーの終了前にその数に達した場合、トークがオーバーランしたスライドに 1000 と表示されるだけです。

これまでのところ、60 から 0 までカウントダウンするコードを見つけましたが、スライドは 1 つしかありません。これを基礎として使用しようとしていますが、VBA とパワーポイントの理解が不足しているため、これまでのところ運がありません。

どんな助けでも大歓迎です。

下の 1 つのスライドだけで動作するカウント ダウン コードを次に示します。

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

どんな助けでも素晴らしいでしょう！

4

1 に答える 1

0

これは、コードを実行する前に、スライド 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
于 2012-10-03T15:02:25.387 に答える