如何用VBA选择PPT中特定自定义版式/含指定形状文本的幻灯片？

一、选中使用指定自定义版式的幻灯片 #

你之前的代码问题在于：直接遍历母版的自定义版式，找到目标版式后就选中所有幻灯片，并没有检查每张幻灯片实际应用的版式。而且Exit For会让循环在找到第一个版式后就停止，完全没关联到具体幻灯片。

正确的做法是遍历所有幻灯片，筛选出使用目标版式的，把它们的索引收集起来，最后一次性选中：

Sub SelectSlidesByCustomLayout()
    Dim targetLayout As CustomLayout
    Dim slideObj As Slide
    Dim slideIndexes As Collection
    Set slideIndexes = New Collection
    
    ' 先找到目标自定义版式（同时匹配Name和Index，确保精准）
    For Each targetLayout In ActivePresentation.SlideMaster.CustomLayouts
        If targetLayout.Name = "1_separator" And targetLayout.Index = 1 Then
            Exit For
        End If
    Next targetLayout
    
    ' 遍历所有幻灯片，收集使用目标版式的幻灯片索引
    If Not targetLayout Is Nothing Then
        For Each slideObj In ActivePresentation.Slides
            If slideObj.CustomLayout Is targetLayout Then
                slideIndexes.Add slideObj.SlideIndex
            End If
        Next slideObj
        
        ' 选中符合条件的幻灯片（如果有匹配项）
        If slideIndexes.Count > 0 Then
            Dim indexArr() As Long
            ReDim indexArr(1 To slideIndexes.Count)
            Dim i As Integer
            For i = 1 To slideIndexes.Count
                indexArr(i) = slideIndexes(i)
            Next i
            ActivePresentation.Slides.Range(indexArr).Select
        Else
            MsgBox "未找到使用指定自定义版式的幻灯片"
        End If
    Else
        MsgBox "未找到名称为1_separator且索引为1的自定义版式"
    End If
End Sub

二、获取包含指定形状或文本的幻灯片 #

1. 筛选包含指定形状的幻灯片（比如按形状名称/类型）

下面的代码会筛选出包含名称为"TitleBox"的形状的幻灯片：

Sub GetSlidesByShape()
    Dim slideObj As Slide
    Dim shapeObj As Shape
    Dim targetSlides As Collection
    Set targetSlides = New Collection
    Dim targetShapeName As String
    targetShapeName = "TitleBox" ' 替换成你要找的形状名称
    
    For Each slideObj In ActivePresentation.Slides
        For Each shapeObj In slideObj.Shapes
            If shapeObj.Name = targetShapeName Then
                targetSlides.Add slideObj
                Exit For ' 找到目标形状就跳出当前幻灯片的形状循环
            End If
        Next shapeObj
    Next slideObj
    
    ' 这里可以对筛选出的幻灯片进行操作，比如选中
    If targetSlides.Count > 0 Then
        Dim indexArr() As Long
        ReDim indexArr(1 To targetSlides.Count)
        Dim i As Integer
        For i = 1 To targetSlides.Count
            indexArr(i) = targetSlides(i).SlideIndex
        Next i
        ActivePresentation.Slides.Range(indexArr).Select
    Else
        MsgBox "未找到包含指定形状的幻灯片"
    End If
End Sub

2. 筛选包含指定文本的幻灯片

下面的代码会筛选出包含指定文本（比如"目录项"）的幻灯片：

Sub GetSlidesByText()
    Dim slideObj As Slide
    Dim shapeObj As Shape
    Dim targetSlides As Collection
    Set targetSlides = New Collection
    Dim targetText As String
    targetText = "目录项" ' 替换成你要找的文本
    
    For Each slideObj In ActivePresentation.Slides
        For Each shapeObj In slideObj.Shapes
            If shapeObj.HasTextFrame And shapeObj.TextFrame.HasText Then
                If InStr(1, shapeObj.TextFrame.TextRange.Text, targetText, vbTextCompare) > 0 Then
                    targetSlides.Add slideObj
                    Exit For ' 找到目标文本就跳出当前幻灯片的形状循环
                End If
            End If
        Next shapeObj
    Next slideObj
    
    ' 操作筛选出的幻灯片
    If targetSlides.Count > 0 Then
        Dim indexArr() As Long
        ReDim indexArr(1 To targetSlides.Count)
        Dim i As Integer
        For i = 1 To targetSlides.Count
            indexArr(i) = targetSlides(i).SlideIndex
        Next i
        ActivePresentation.Slides.Range(indexArr).Select
    Else
        MsgBox "未找到包含指定文本的幻灯片"
    End If
End Sub

三、自动目录的实现思路 #

结合上面的筛选逻辑，自动目录可以这么做：

1. 先筛选出你想要加入目录的幻灯片（比如使用1_separator版式的幻灯片，或者包含特定文本的幻灯片）
2. 在演示文稿开头或指定位置插入一张空白幻灯片作为目录页
3. 遍历筛选出的幻灯片，把它们的标题（或指定文本）添加到目录页的文本框中
4. 给每个目录项添加超链接，点击可以跳转到对应的幻灯片

示例代码（基于筛选1_separator版式的幻灯片生成目录）：

Sub GenerateAutoCatalog()
    Dim targetLayout As CustomLayout
    Dim slideObj As Slide
    Dim catalogSlide As Slide
    Dim catalogTextbox As Shape
    Dim catalogContent As String
    Dim slideIndex As Integer
    
    ' 找到目标版式
    For Each targetLayout In ActivePresentation.SlideMaster.CustomLayouts
        If targetLayout.Name = "1_separator" And targetLayout.Index = 1 Then
            Exit For
        End If
    Next targetLayout
    
    If targetLayout Is Nothing Then
        MsgBox "未找到指定自定义版式"
        Exit Sub
    End If
    
    ' 插入目录页（插入到第1张位置）
    Set catalogSlide = ActivePresentation.Slides.Add(1, ppLayoutTitle)
    catalogSlide.Shapes(1).TextFrame.TextRange.Text = "自动生成目录"
    
    ' 添加文本框用于存放目录项
    Set catalogTextbox = catalogSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
        Left:=100, Top:=150, Width:=500, Height:=400)
    
    ' 收集目录内容并添加超链接
    catalogContent = ""
    For Each slideObj In ActivePresentation.Slides
        If slideObj.CustomLayout Is targetLayout And slideObj.SlideIndex <> 1 Then ' 排除目录页自己
            catalogContent = catalogContent & slideObj.SlideIndex & ". " & slideObj.Shapes(1).TextFrame.TextRange.Text & vbCrLf
            ' 添加超链接：文本框中的对应行链接到幻灯片
            With catalogTextbox.TextFrame.TextRange
                .Text = catalogContent
                .Characters(.Length - Len(slideObj.Shapes(1).TextFrame.TextRange.Text) - 2, _
                    Len(slideObj.Shapes(1).TextFrame.TextRange.Text) + 2).ActionSettings(ppMouseClick).Hyperlink.SubAddress = _
                    slideObj.SlideIndex & "," & slideObj.SlideIndex
            End With
        End If
    Next slideObj
    
    If catalogContent = "" Then
        catalogTextbox.TextFrame.TextRange.Text = "无符合条件的目录项"
    End If
End Sub

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