Consulting

Results 1 to 5 of 5

Thread: Table of Contents in PowerPoint VBA

  1. #1
    VBAX Contributor
    Joined
    Dec 2018
    Posts
    105
    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.

  2. #2
    VBAX Sage
    Joined
    Apr 2007
    Posts
    7,889
    Location
    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
    Attached Files Attached Files
    ---------------------------------------------------------------------------------------------------------------------

    Paul


    Remember: Tell us WHAT you want to do, not HOW you think you want to do it

    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  3. #3
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,704
    Location
    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."
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  4. #4
    VBAX Contributor
    Joined
    Dec 2018
    Posts
    105
    Location
    Thank you Paul and Sam, your knowledge is outstanding; much obliged. Thank you.

  5. #5
    Moderator VBAX Sage SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,704
    Location
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

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
  •