Table of Contents in PowerPoint VBA

[Paul_Hossler]

1. I added CODE tags. This is your 104th post, so we should not have to do it

2. Code is MUCH easier for others (at least me) to read if you use indenting and blank lines. Admittedly, there is some personal style involved

3. Never just put an "On Error Resume Next" (especially first line) "just in case". You need the errors to see what needs to be corrected.
There are times when it is appropriate, but that wasn't one of them

4. Big issue after I reformatted so I could more easily follow it, was that you kept using 'SlideRange' where I think you wanted to use the array 'SlideFollow'



At least this seems to work

Option Explicit


Sub DirectoryWithoutHyperlinks()
    'Insert directory without hyperlinks
    Agenda (False)
End Sub


Sub DirectoryWithHyperlinks()
    'Insert Directory with Hyperlinks
    Agenda (True)
End Sub


Sub Agenda(Optional Hyperlinks As Boolean)
    Dim i As Integer
    Dim o As Integer
    Dim strSel As String
    Dim strTitel As String
    Dim strAgendaTitel As String
    Dim slAgenda As Slide
    Dim intPos As Integer
    Dim SlideFollow() As Integer
    
'    On Error Resume Next  <<<<<<<<<<<<<<<<<<<<<<<< VERY VERY VERY BAD to have at start (or any place usually)
    If ActiveWindow.Selection.SlideRange.Count = 0 Then Exit Sub
    
    ReDim SlideFollow(1 To ActiveWindow.Selection.SlideRange.Count)
    
    'Select position for content slides
    intPos = InputBox("Which slides should the agenda be inserted before?", "Position of the agenda")
    
    'Cancel if the value is greater than the number of slides
    If intPos > ActivePresentation.Slides.Count Then
        MsgBox "The selected value is greater than the number of slides in the presentation.“"
        Exit Sub
    End If


    'Enter the title of the content slide
    strAgendaTitel = InputBox("What heading do you want for the content slide?", "Enter titles")
    
    'Determining the IDs of selected slides
    For i = 1 To ActiveWindow.Selection.SlideRange.Count
        SlideFollow(i) = ActiveWindow.Selection.SlideRange(i).SlideIndex
    Next
    
    For o = 1 To UBound(SlideFollow)
        If ActivePresentation.Slides(SlideFollow(o)).Shapes.HasTitle Then
        'Build up the ToC Text
            strTitel = ActivePresentation.Slides(SlideFollow(o)).Shapes.Title.TextFrame.TextRange.Text
            strSel = strSel & strTitel & vbCrLf
        End If
    Next
    
    'Insert blank slides where you want, enter titles and headings
    Set slAgenda = ActivePresentation.Slides.Add(intPos, ppLayoutText)
    slAgenda.Shapes(1).TextFrame.TextRange = strAgendaTitel
    slAgenda.Shapes(2).TextFrame.TextRange = strSel
    
    'Insert Hyperlinks
    If Hyperlinks Then
        For o = 1 To UBound(SlideFollow)
            If ActivePresentation.Slides(SlideFollow(o) + 1).Shapes.HasTitle Then
                'Build up the ToC Text
                strTitel = ActivePresentation.Slides(SlideFollow(o) + 1).Shapes.Title.TextFrame.TextRange.Text
                With slAgenda.Shapes(2).TextFrame.TextRange.Paragraphs(o).ActionSettings(ppMouseClick)
                    .Action = ppActionHyperlink
                    .Hyperlink.Address = ""
                    .Hyperlink.SubAddress = ActivePresentation.Slides(SlideFollow(o) + 1).SlideID & "," & ActivePresentation.Slides(SlideFollow(o) + 1).SlideIndex & "," + strTitel
                End With
            End If
        Next
    End If


End Sub