Consulting

Results 1 to 5 of 5

Thread: Table of Contents in PowerPoint VBA

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #1
    VBAX Contributor
    Joined
    Dec 2018
    Location
    South London
    Posts
    115
    Location

    Table of Contents in PowerPoint VBA

    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===
    Last edited by Paul_Hossler; 04-30-2021 at 08:06 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •