Table of Contents in PowerPoint VBA

[RayKay]

Hi John, and readers, I'm hoping you can help me on the code below.

It creates a slide with a table of contents. You select slides first then click choose the macro (hyperlinked or not).

I get an error message "Compile error: Sub or Function not defined" at the text I put in red font (half way down).

So grateful for any help, and thank you for your time.

===VBA CODE START===

Option Explicit
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
If ActiveWindow.Selection.SlideRange.Count > 0 Then
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
SlideRange(i) = ActiveWindow.Selection.SlideRange(i).SlideIndex
Next
For o = 1 To UBound(SlideRange)
If ActivePresentation.Slides(SlideRange(o)).Shapes.HasTitle Then
'Build up the ToC Text
strTitel = ActivePresentation.Slides(SlideRange (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(FolienFolge)
If ActivePresentation.Slides(SlideRange(o) + 1).Shapes.HasTitle Then
'Build up the ToC Text
strTitel = ActivePresentation.Slides(SlideRange(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(SlideRange(o) + 1).SlideID & "," & ActivePresentation.Slides(SlideRange(o) + 1).SlideIndex & "," + strTitel
End With
End If
Next
End If
End If
End Sub
Sub DirectoryWithoutHyperlinks()
'Insert directory without hyperlinks
Agenda (False)
End Sub
Sub DirectoryWithHyperlinks()
'Insert Directory with Hyperlinks
Agenda (True)
End Sub

===VBA CODE END===

[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

[SamT]

SlideRange is Not a "Stand alone" Collection. You can have "Application.SlideRange", "ActivePresntation.SlideRange", "Selection SlideRange", but not "SlideRange"

You can define your own Collection, that is standalone:

Dim MySlideRange as Collection
MySlideRange = Application.SlideRange
'Or
MySlideRange.Add Selection.Slides(1)
'then
Tmp = MySlideRange(i)

'I thimk you can make a  standalone by
Dim MySlideRange as SlideRange
'But I'm not sure

Aslo, I see you using the SlideRange as both a collection and as an Array (Used both Count and UBound)


Formatting in re Paul's code is really a must for all coders.

"Hyperlinks" is a PPT Keyword. Using it may cause Compiler confusion. I suggest changing it to "UsesHyperlinks."

"Hyperlinks" is a collection of URLs: "UsesHyperlinks" implies "yes/No" or "True/False", or even "Not Zero/Zero."

[RayKay]

Thank you Paul and Sam, your knowledge is outstanding; much obliged. Thank you.

[SamT]