Code: Select all
Sub AgendaLinks()
Dim oSld As Slide
Dim oShp As Shape
Dim oAgenda As TextRange
Dim x As Integer
' Add a slide to the beginning of presentation
ActivePresentation.Slides.Add 1, ppLayoutText
With ActivePresentation.Slides(1)
.Shapes(1).TextFrame.TextRange = "Agenda Slide"
Set oAgenda = .Shapes(2).TextFrame.TextRange
End With
oAgenda = ""
For Each oSld In ActivePresentation.Slides
' Does the slide have title placeholder?
If oSld.Shapes.HasTitle Then
' Get the reference to the title shape on the slide
Set oShp = oSld.Shapes.Title
' Check if the placeholder has any text in it.
If oShp.TextFrame.TextRange.Text = "" Then
oAgenda = oAgenda & "Slide " & oSld.SlideIndex & Chr(13)
Else
oAgenda = oAgenda & oShp.TextFrame.TextRange.Text & Chr(13)
End If
Else
oAgenda = oAgenda & "Slide " & oSld.SlideIndex & Chr(13)
End If
Next oSld
' Add hyperlinks to the titles.
For x = 1 To oAgenda.Sentences.Count
Set oSld = ActivePresentation.Slides(x)
With oAgenda.Sentences(x) _
.ActionSettings(ppMouseClick).Hyperlink
.Address = ""
' Hyperlink - Slide ID, Slide Index, Slide Title
.SubAddress = oSld.SlideID & "," & _
oSld.SlideIndex & "," & _
oAgenda.Sentences(x).Text
End With
Next x
' Delete the first one because it points to the agenda slide.
oAgenda.Sentences(1).Delete
End Sub
