Create animated random image display tool in VBA

问题

I have a PowerPoint slide with different images. I need to create VBA code in PowerPoint that recognises all these images and fades them out one by one - except for one randomly chosen image. This last image should remain until the end, then fade out and display in the middle of the slide.

I have an idea of how to do it and have experience with object oriented languages (R) but I have never used VBA before. Therefore I would be grateful for pointers on how to do any of the following in VBA:

1. Determine number of images on active slide
2. Select each image one after another and assign a counter variable as selection label (that part should work as described here)
3. Create "Range A" of all assigned counter variables
4. Select random number "x" in "Range A"
5. Create "Range B" of all counter variables in "Range A" EXCEPT for the random number "x"
6. Randomise the order of variables in "Range B"
7. Loop through "Range B" and fade out images whose label corresponds to the respective "Range B" variable that comes up
8. Fade out the image whose label corresponds to "x"
9. Insert the image whose label corresponds to "x" in the centre of the slide

If it is very difficult to recognise images or assign labels to those images I can also do so manually. However, it would be nicer if that could happen automatically. I would be grateful for any pointers, also in the form of links if you think that part of the above process is already described somewhere else (I'm afraid since I'm inexperienced in VBA I am not using very effective search terms).

EDIT: Please find the solution (steps 8 and 9 are still missing)

Sub SelectionMacro()

Dim oSl As Slide
Dim oSh As Shape
Dim aArrayOfShapes() As Variant
Dim ShapeX As Shape
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim FadeEffect As Effect

Set oSl = ActivePresentation.SlideS(1)

'This section creates an array of all pictures on Slide1 called
'"aArrayOfShapes"
For Each oSh In oSl.Shapes
    If oSh.Type = msoPicture Then
        On Error Resume Next
        Debug.Print UBound(aArrayOfShapes)
        If Err.Number = 0 Then
            ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes) + 1)
        Else
            ReDim Preserve aArrayOfShapes(1 To 1)
        End If
        Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
    End If
Next

'This section creates a random index number within the bounds of the
'length of aArrayOfShapes and assigns the shape with that index number
'to the Shape object ShapeX
Randomize
NumberX = Int((UBound(aArrayOfShapes) - (LBound(aArrayOfShapes) - 1)) * Rnd) + LBound(aArrayOfShapes)
Set ShapeX = aArrayOfShapes(NumberX)

'This section shuffles aArrayOfShapes
For N = LBound(aArrayOfShapes) To UBound(aArrayOfShapes)
    J = CLng(((UBound(aArrayOfShapes) - N) * Rnd) + N)
        If N <> J Then
            Set Temp = aArrayOfShapes(N)
            Set aArrayOfShapes(N) = aArrayOfShapes(J)
            Set aArrayOfShapes(J) = Temp
        End If
    Next N

'This section loops through all Shapes in aArrayOfShapes and
'fades them out one by one EXCEPT for ShapeX
For Each Shape In aArrayOfShapes
    If ShapeX.Name <> Shape.Name Then
    Set FadeEffect = oSl.TimeLine.MainSequence.AddEffect _
    (Shape:=Shape, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerAfterPrevious)
        With FadeEffect
        .Timing.Duration = 0.5
        .Exit = msoTrue
        End With
    End If
Next Shape

End Sub

In order to reset the slide to the state before running the macro (so as to be able to run it again and display another random image) the following macro needs to be run:

Sub ResetSelection()
    For i = ActivePresentation.SlideS(1).TimeLine.MainSequence.Count To 1 Step -1
        ActivePresentation.SlideS(1).TimeLine.MainSequence(i).Delete
    Next i
End Sub

回答1:

Working out the range of images shouldn't be too hard. This'll get you started. Assigning animation to shapes can be tricky. You might be better off duplicating the slide with all the images then deleting all but a randomly chosen image.

Dim oSl As Slide
Dim oSh As Shape

' Dynamic array of shapes to hold shape references
Dim aArrayOfShapes() As Shape

Set oSl = ActiveWindow.Selection.SlideRange(1)

For Each oSh In oSl.Shapes
    If oSh.Type = msoPicture Then
        On Error Resume Next
        Debug.Print UBound(aArrayOfShapes)
        If Err.Number = 0 Then
            ReDim Preserve aArrayOfShapes(1 To UBound(aArrayOfShapes))
        Else
            ReDim Preserve aArrayOfShapes(1 To 1)
        End If
        Set aArrayOfShapes(UBound(aArrayOfShapes)) = oSh
    End If
Next`enter code here`


' Now you have an array containing references to all the pictures
' on the slide.  You can use a random number function to return
' an index into the array to choose a picture at random.

With aArrayOfShapes(RandomNumberFunction(LBound(aArrayOfShapes), UBound(aArrayOfShapes)))
' google to find an appropriate function; they're out there

    ' do whatever you need to do with your shapes here

End With

来源：https://stackoverflow.com/questions/30003173/create-animated-random-image-display-tool-in-vba