VBA MAcro to generate "table of contents with hyperlinks" automatically in a ppt

VBA MAcro to generate "table of contents with hyperlinks" automatically in a ppt:



Function TableOfContent(count As Integer)
'count is the no. of slides in ppt
Dim var As Integer
Dim i As Integer, scount As Integer
Dim strSel As String, strTitle As String, strb As String, strtemp As String, str As String
Dim arr() As String
Dim index As Integer, indexcount As Integer, slidecount As Integer
Dim summary As Slide
Dim para As Integer
Dim slideOrder() As Integer


'To generate the Table of contents slide
ReDim slideOrder(count - 2)

'Collect all the IDs of the selected slides
For i = 1 To count - 2
slideOrder(i) = i + 2
Next

'Iterate over the slides in Index order
slidecount = UBound(slideOrder)
For scount = 1 To slidecount
If ActivePresentation.Slides(slideOrder(scount)).Shapes.HasTitle Then
'Build up the ToC Text
strTitle = ActivePresentation.Slides(slideOrder(scount)).Shapes("UseCase").TextFrame.TextRange.Text + ": "
str = ActivePresentation.Slides(slideOrder(scount)).Shapes("Configuration").TextFrame.TextRange.Text
strSel = strSel & strTitle & str & vbNewLine
End If
Next

'Create the summary slide before the first slide in the selection
arr = Split(strSel, vbNewLine)

Dim tocSlide As Double, initialValue As Integer

tocSlide = slidecount / 40

If Int(tocSlide) / tocSlide <> 1 Then
tocSlide = Int(tocSlide) + 1
End If

initialValue = tocSlide + 2


For k = 1 To tocSlide
Set summary = ActivePresentation.Slides.Add(slideOrder(k), ppLayoutTwoColumnText)

'Add the title
summary.Shapes(1).TextFrame.TextRange = "Table of Contents"
'Add the ToC text
With summary.Shapes(2).TextFrame.TextRange
.Font.Name = "Times New Roman"
.Font.Size = 10
End With

With summary.Shapes(3).TextFrame.TextRange
.Font.Name = "Times New Roman"
.Font.Size = 10
End With

summary.Shapes(2).TextFrame.TextRange.Paragraphs.ParagraphFormat.Bullet.Type = ppBulletNumbered
summary.Shapes(3).TextFrame.TextRange.Paragraphs.ParagraphFormat.Bullet.Type = ppBulletNumbered
summary.Shapes(2).TextFrame.TextRange.Paragraphs.ParagraphFormat.Bullet.StartValue = initialValue
summary.Shapes(3).TextFrame.TextRange.Paragraphs.ParagraphFormat.Bullet.StartValue = initialValue + 20

strtemp = ""
'strtemp2 = ""

'to break into multiple slides
If (indexcount + 20) < UBound(slideOrder) Then For index = indexcount To indexcount + 19 strtemp = strtemp & arr(index) & vbNewLine Next Else For index = indexcount To UBound(slideOrder) 'MsgBox (arr(t - 1)) strtemp = strtemp & arr(index) & vbNewLine Next End If summary.Shapes(2).TextFrame.TextRange = strtemp strtemp = "" indexcount = index If (indexcount + 20) < UBound(slideOrder) Then For index = indexcount To indexcount + 19 strtemp = strtemp & arr(index) & vbNewLine Next Else For index = indexcount To UBound(slideOrder) strtemp = strtemp & arr(index) & vbNewLine Next End If summary.Shapes(3).TextFrame.TextRange = strtemp indexcount = index initialValue = initialValue + 40 Next para = 1 'to check the paragraph index in shapes index = 1 'Adding Hyperlinks For k = 1 To tocSlide var = 0 'to set the shape as 2 or 3 Set summary = ActivePresentation.Slides(slideOrder(k)) If (index + 39) < UBound(slideOrder) Then For scount = index To index + 39 If (para > 20) Then
para = 1
End If

If ActivePresentation.Slides(slideOrder(scount) + tocSlide).Shapes.HasTitle Then
'Build up the ToC Text
strTitle = ActivePresentation.Slides(slideOrder(scount) + tocSlide - 1).Shapes.Title.TextFrame.TextRange.Text
' MsgBox (summary.Shapes(2).TextFrame.TextRange.Paragraphs(o))
With summary.Shapes(2 + var).TextFrame.TextRange.Paragraphs(para).ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = ""
.Hyperlink.SubAddress = ActivePresentation.Slides(slideOrder(scount) + tocSlide).SlideID & "," & ActivePresentation.Slides(slideOrder(scount) + tocSlide).SlideIndex & "," + strTitle
End With
End If

If (scount Mod 20 = 0) Then
var = 1
End If

para = para + 1
Next

Else

' var = (UBound(slideOrder)) - 40 * (k - 1)
para = 1
For scount = index To UBound(slideOrder)

If (para > 20) Then
para = 1
End If

If ActivePresentation.Slides(slideOrder(scount) + tocSlide).Shapes.HasTitle Then
'Build up the ToC Text
strTitle = ActivePresentation.Slides(slideOrder(scount) + tocSlide - 1).Shapes.Title.TextFrame.TextRange.Text
' MsgBox (summary.Shapes(2).TextFrame.TextRange.Paragraphs(o))
With summary.Shapes(2 + var).TextFrame.TextRange.Paragraphs(para).ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.Address = ""
.Hyperlink.SubAddress = ActivePresentation.Slides(slideOrder(scount) + tocSlide).SlideID & "," & ActivePresentation.Slides(slideOrder(scount) + tocSlide).SlideIndex & "," + strTitle
End With
End If

' MsgBox (index Mod 20)
If (scount Mod 20 = 0) Then
var = 1
End If
para = para + 1
Next

End If

index = index + 40
Next

End Function


Note: This macro generates index with maximum links to be accomodated on the page. Minor changes can be done as per need.