在 VBA 中创建动画随机图像显示工具

Question

我有一张包含不同图像的 PowerPoint 幻灯片。我需要在 PowerPoint 中创建 VBA 代码，以识别所有这些图像并将它们一一淡出 - 除了一个随机选择的图像。最后一张图片应该一直保留到最后，然后淡出并显示在幻灯片的中间。

我知道如何去做，并且有使用面向对象语言 (R) 的经验，但我以前从未使用过 VBA。因此，我将不胜感激如何在 VBA 中执行以下任何操作：

1. 确定活动幻灯片上的图像数量
2. 依次选择每个图像并分配一个计数器变量作为选择标签（该部分应该按照here 的描述工作）
3. 创建所有已分配计数器变量的“范围 A”
4. 在“范围A”中选择随机数“x”
5. 为“范围 A”中的所有计数器变量创建“范围 B”，随机数“x”除外
6. 随机化“范围 B”中变量的顺序
7. 遍历“范围 B”并淡出标签对应于出现的相应“范围 B”变量的图像
8. 淡出标签对应“x”的图片
9. 在幻灯片中心插入标签对应“x”的图片

如果很难识别图像或为这些图像分配标签，我也可以手动进行。但是，如果这可以自动发生，那就更好了。如果您认为上述过程的一部分已经在其他地方进行了描述，我将不胜感激任何指针，也以链接的形式（我担心因为我在 VBA 方面没有经验，所以我没有使用非常有效的搜索词）。

编辑： 请找到解决方案（步骤 8 和 9 仍然缺失）

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

为了将幻灯片重置为运行宏之前的状态（以便能够再次运行并显示另一个随机图像），需要运行以下宏：

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

Answer 1

计算图片的范围应该不会太难。这会让你开始。 将动画分配给形状可能很棘手。您最好用所有图像复制幻灯片，然后删除除随机选择的图像之外的所有图像。

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