Table of contents in PowerPoint

Question

I need you: I should insert a dynamic index (which also updates the page number associated with the title) in my PowerPoint presentation.

I have searched online but have not found any solution; the only one approaching uses a VBA macro (the code below) which is based on the hyper-textual link: when the macro is launched it updates the page number in the index but subsequently the link is deleted and therefore it is necessary reinsert it manually.

Is there any way to automate the process? Thank you.

Sub TableOfContentUpdater()
    Dim pTableOfContent As Slide
    Set pTableOfContent = ActivePresentation.Slides(2)
    
    For Each pHyperLink In pTableOfContent.Hyperlinks
        Dim pLinkNumber As String
        Dim pLinkedSlide As Slide
        pLinkNumber = Left(pHyperLink.SubAddress, InStr(pHyperLink.SubAddress, ",") - 1)
        pHyperLink.TextToDisplay = ActivePresentation.Slides.FindBySlideID(CLng(pLinkNumber)).SlideIndex
    Next pHyperLink
End Sub

Answer 1

I've developed a script for generating an entire table of contents in PowerPoint from scratch that loops through all of the slides and assembles their header text along with their relative slide number and applies the appropriate hyperlink. Here is the code:

    For slideNum = 1 To ActivePresentation.Slides.Count
        If slideNum > 1 Then
            If ActivePresentation.Slides(slideNum).Shapes.HasTitle Then
                slideHeader = ActivePresentation.Slides(slideNum).Shapes.Title.TextFrame.TextRange.Text & "..........................................................................." & "slide: " & slideNum + 1
                TOC_SlideList = TOC_SlideList & slideHeader & vbCrLf
            End If
        End If
    Next
    Set TOC = ActivePresentation.Slides.Add(2, ppLayoutText)
    TOC.Shapes(1).TextFrame.TextRange = "Table of Contents"
    TOC.Shapes(2).TextFrame.TextRange = TOC_SlideList
    For slideNum = 1 To ActivePresentation.Slides.Count
        If slideNum > 2 Then
            If ActivePresentation.Slides(slideNum).Shapes.HasTitle Then
                slideHeader = ActivePresentation.Slides(slideNum).Shapes.Title.TextFrame.TextRange.Text
                With TOC.Shapes(2).TextFrame.TextRange.Paragraphs(slideNum - 2).Find("slide: " & slideNum).ActionSettings(ppMouseClick)
                    .Action = ppActionHyperlink
                    .Hyperlink.Address = ""
                    .Hyperlink.SubAddress = ActivePresentation.Slides(slideNum).SlideID & "," & ActivePresentation.Slides(slideNum).SlideIndex & "," + slideHeader
                End With
            End If
        End If
    Next
End Sub

The preceding code produces the following result:

Combining this example with your usage case, we can loop through and map the hyperlink names, slide indexes, and destinations in array lists. Then, we can use the arrays to update the links appropriately.

Here is the example code:

Sub TableOfContentUpdater()
    Dim pTableOfContent As Slide
    Set pTableOfContent = ActivePresentation.Slides(2)
    Dim pLinkNumber As String
    Dim pLinkedSlide As Slide
    Dim pHyperLink As Hyperlink
    ReDim subAddresses(pTableOfContent.Hyperlinks.Count - 1) As Variant
    ReDim oldNames(pTableOfContent.Hyperlinks.Count - 1) As Variant
    ReDim newNames(pTableOfContent.Hyperlinks.Count - 1) As Variant
    Dim i As Integer
    For Each pHyperLink In pTableOfContent.Hyperlinks
        subAddresses(i) = pHyperLink.SubAddress
        pLinkNumber = Left(pHyperLink.SubAddress, InStr(pHyperLink.SubAddress, ",") - 1)
        newNames(i) = ActivePresentation.Slides.FindBySlideID(CLng(pLinkNumber)).SlideIndex
        pHyperLink.TextToDisplay = newNames(i)
        i = i + 1
    Next pHyperLink
    i = 0
    For Each pHyperLink In pTableOfContent.Hyperlinks
        pHyperLink.Delete
        i = i + 1
    Next pHyperLink
    i = 0
    For Each pSubAddress In subAddresses
        With pTableOfContent.Shapes(2).TextFrame.TextRange.Paragraphs(i + 1).Find(newNames(i)).ActionSettings(ppMouseClick)
            .Action = ppActionHyperlink
            .Hyperlink.Address = ""
            .Hyperlink.SubAddress = pSubAddress
        End With
    i = i + 1
   Next pSubAddress
End Sub

When applied to the spreadsheet that was created above, this is the result: