Sub Build_Index()
Dim Mstr As CustomLayout
Dim SlidePosition As Integer
Dim Activeslide As PowerPoint.Slide
Dim TOCSlide As PowerPoint.Slide
Dim I As Integer
Dim Issues As Collection
Dim Issue As String
Dim FoundSlide As PowerPoint.Slide
Dim bodyText As PowerPoint.TextFrame
Dim sldID As Long
Dim sldindx As Long
Dim hypStart As Long
'assign custom objects
Set Mstr = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set Activeslide = Application.ActiveWindow.View.Slide
' determine required inputs
SlidePosition = Activeslide.SlideIndex
'insert slide to hold TOC at current location
Set TOCSlide = ActivePresentation.Slides.AddSlide(SlidePosition, Mstr)
TOCSlide.Shapes.Title.TextFrame.TextRange = "Index"
Set bodyText = TOCSlide.Shapes.Placeholders(2).TextFrame
'loop through each slide compiling TOC from slide titles
Set Issues = GetIssues
I = 1
For I = I To Issues.Count
Issue = Issues(I)
Debug.Print Issue
Set FoundSlide = FindSlide(Issue)
' add Issue to page as text
bodyText.TextRange.InsertAfter (Issue & " " & Chr(13))
' create a hyperlink entry for TOC rather than a simple text entry
' get the information required for the hyperlink
sldID = FoundSlide.SlideID
sldindx = FoundSlide.SlideIndex
' find the text string in the body
hypStart = InStr(1, bodyText.TextRange.Text, Issue, 1)
'make the text a hyperlink
With bodyText.TextRange.Characters(hypStart, Len(Issue)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = FoundSlide.slideNumber
End With
Debug.Print sldID & "," & sldindx & "," & Issue
Next I
'release object
Set Mstr = Nothing
Set Activeslide = Nothing
Set TOCSlide = Nothing
Set bodyText = Nothing
End Sub
Public Function GetIssues() As Collection
Dim Issues As New Collection
Issues.Add ("IS 485")
Issues.Add ("IS 486")
Issues.Add ("AR 650")
Set GetIssues = Issues
End Function
Public Function FindSlide(StrText As String) As PowerPoint.Slide
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim txtRng As PowerPoint.TextRange
Dim rngFound As PowerPoint.TextRange
Dim I As Long
Dim n As Long
On Error GoTo errlbl
For Each sld In Application.ActivePresentation.Slides
'~~> Loop through each shape
For Each shp In sld.Shapes
'~~> Check if it has text
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
'~~> Find the text
Set rngFound = txtRng.Find(StrText)
'~~~> If found
If Not rngFound Is Nothing Then
Set FindSlide = sld
Exit Function
End If
End If
Next
Next
Set shp = Nothing
Set sld = Nothing
Exit Function
errlbl:
MsgBox Err.Number & " " & Err.Description
End Function
