PPT VBA宏故障：点击形状跳转随机幻灯片后无法显示对应文本

我需要实现的功能是：点击带有文本的形状时，跳转到指定范围（示例为21-30号幻灯片）内未重复的随机幻灯片，并在该幻灯片右上角添加一个形状，显示点击形状名称的首字符。目前宏能成功跳转到随机幻灯片，但无法显示对应的首字符文本。

现有代码 #

Dim lowestSlide As Integer
Dim highestSlide As Integer
Dim r As Integer

Sub PlayGame(lowestSlide As Integer, highestSlide As Integer)
    RandomSlide lowestSlide, highestSlide
    SlideShowWindows(1).View.GotoSlide (r)
    AddLetterToSlide
End Sub

Sub RandomSlide(lowestSlide As Integer, highestSlide As Integer)
    Dim slideCount As Integer
    slideCount = highestSlide - lowestSlide + 1
    
    'Create an array to keep track of which slides have already been shown
    Dim chosenSlides() As Boolean
    ReDim chosenSlides(1 To slideCount)
    
    'Begin with all slides set as not chosen
    Dim i As Integer
    For i = 1 To slideCount
        chosenSlides(i) = False
    Next
    
    'Choose a random slide that hasn't been chosen yet
    Dim chosenSlide As Integer
    Do
        chosenSlide = Int(slideCount * Rnd + 1)
    Loop While chosenSlides(chosenSlide)
    
    'Mark the chosen slide as chosen
    chosenSlides(chosenSlide) = True
    
    'Map the chosen slide number to the corresponding slide number in the PPT
    r = chosenSlide + lowestSlide - 1
End Sub

Sub Easy()
    PlayGame 21, 30
End Sub

Sub AddLetterToSlide()
    Dim selectedShape As shape
    Set selectedShape = Application.ActiveWindow.Selection.ShapeRange(1)
    Dim selectedLetter As String
    selectedLetter = Left(selectedShape.Name, 1)
    InsertLetterOrNumber selectedLetter
End Sub

Sub InsertLetterOrNumber(selectedLetter As String)
    'Add a new textbox to the slide
    Dim newTextbox As shape
    Set newTextbox = ActivePresentation.Slides(r).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=ActivePresentation.Slides(r).Master.Width - (5 * 72), _
        Top:=0, Width:=5 * 72, Height:=2 * 72)
    
    'Set the textbox properties
    With newTextbox
        .Line.ForeColor.RGB = RGB(0, 0, 0) 'Black border
        .Fill.ForeColor.RGB = RGB(255, 255, 255) 'White background
        .TextFrame.TextRange.Text = selectedLetter 'Text to display
        .TextFrame.TextRange.Font.Name = "Arial" 'Font name
        .TextFrame.TextRange.Font.Size = 24 'Font size
        .TextFrame.TextRange.Find.Color.RGB = RGB(0, 0, 0) 'Font color
        .TextFrame.TextRange.Font.Bold = msoTrue
        .TextFrame.TextRange.Font.Italic = msoTrue
        .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignRight 'Align text to the right
        .ZOrder msoBringToFront 'Bring textbox to front
    End With
End Sub

问题分析 #

1. 放映模式下无法获取选中形状：幻灯片放映时，Application.ActiveWindow.Selection.ShapeRange(1)无法获取点击的形状，此时Selection对象为空，导致AddLetterToSlide无法获取目标字符。
2. 未重复逻辑失效：chosenSlides是局部数组，每次调用RandomSlide都会重新初始化，无法记录已选中的幻灯片，根本实现不了“未重复”跳转。
3. 字体颜色设置错误：原代码用.TextFrame.TextRange.Find.Color.RGB设置字体颜色，这是错误用法，应该直接修改Font.Color。

解决方案 #

1. 重构宏的触发逻辑，传递点击的形状对象 #

替换原Easy()子程序，改为接收形状参数的版本，直接获取点击的形状：

Sub Easy_Clicked(shp As Shape)
    PlayGameWithShape 21, 30, shp
End Sub

2. 全局变量记录已选幻灯片（模块顶部声明） #

Dim chosenSlides() As Boolean
Dim lowestGlobal As Integer
Dim highestGlobal As Integer

3. 实现真正的无重复随机跳转与字符插入 #

Sub PlayGameWithShape(lowestSlide As Integer, highestSlide As Integer, clickedShape As Shape)
    ' 初始化全局数组（仅当范围变化时重置）
    If lowestGlobal <> lowestSlide Or highestGlobal <> highestSlide Then
        lowestGlobal = lowestSlide
        highestGlobal = highestSlide
        ReDim chosenSlides(lowestSlide To highestSlide)
        ' 初始化为未选中状态
        Dim i As Integer
        For i = lowestSlide To highestSlide
            chosenSlides(i) = False
        Next i
    End If
    
    Dim targetSlideNum As Integer
    targetSlideNum = GetUniqueRandomSlide(lowestSlide, highestSlide)
    
    ' 跳转到目标幻灯片
    SlideShowWindows(1).View.GotoSlide targetSlideNum
    
    ' 在目标幻灯片插入首字符
    InsertLetterToSlide targetSlideNum, Left(clickedShape.Name, 1)
End Sub

Function GetUniqueRandomSlide(lowestSlide As Integer, highestSlide As Integer) As Integer
    Dim remainingSlides As Integer
    remainingSlides = 0
    
    ' 统计剩余未选中的幻灯片数量
    Dim i As Integer
    For i = lowestSlide To highestSlide
        If Not chosenSlides(i) Then
            remainingSlides = remainingSlides + 1
        End If
    Next i
    
    ' 所有幻灯片都已选中时重置数组
    If remainingSlides = 0 Then
        For i = lowestSlide To highestSlide
            chosenSlides(i) = False
        Next i
        remainingSlides = highestSlide - lowestSlide + 1
    End If
    
    ' 随机选择一个未选中的幻灯片
    Dim randomIndex As Integer
    randomIndex = Int(Rnd * remainingSlides) + 1
    Dim count As Integer
    count = 0
    For i = lowestSlide To highestSlide
        If Not chosenSlides(i) Then
            count = count + 1
            If count = randomIndex Then
                chosenSlides(i) = True
                GetUniqueRandomSlide = i
                Exit Function
            End If
        End If
    Next i
End Function

Sub InsertLetterToSlide(slideNum As Integer, displayText As String)
    Dim targetSlide As Slide
    Set targetSlide = ActivePresentation.Slides(slideNum)
    
    ' 添加文本框到幻灯片右上角
    Dim newTextbox As Shape
    Set newTextbox = targetSlide.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=targetSlide.Master.Width - (5 * 72), _
        Top:=0, _
        Width:=5 * 72, _
        Height:=2 * 72)
    
    ' 设置文本框属性
    With newTextbox
        .Line.ForeColor.RGB = RGB(0, 0, 0)
        .Fill.ForeColor.RGB = RGB(255, 255, 255)
        .TextFrame.TextRange.Text = displayText
        .TextFrame.TextRange.Font.Name = "Arial"
        .TextFrame.TextRange.Font.Size = 24
        .TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
        .TextFrame.TextRange.Font.Bold = msoTrue
        .TextFrame.TextRange.Font.Italic = msoTrue
        .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignRight
        .ZOrder msoBringToFront
    End With
End Sub

4. 绑定宏到形状 #

右键点击目标形状 → 分配宏 → 选择Easy_Clicked（该宏会自动出现在列表中，因为它接受Shape参数）。

内容的提问来源于stack exchange，提问作者papercutter0324