Skip to main content

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.

Comments

  1. if else and for loops incomplete

    ReplyDelete
  2. I am using your macro to generate a table of content with hyperlink; however, I am getting a compile error expected end sub.....

    I copied the formula from Function Table to End Function

    I can be contacted at miguel_reid@hotmail.com

    ReplyDelete
  3. Not getting macro in ppt that you gave me to work. Copied from Function Table to End Function. However I am getting a compile error expected End Sub?
    program same as that at :http://jainhim.blogspot.com/2012/11/vba-macro-to-generate-table-of-contents.html#comment-form.

    Function TableOfContent(count As Integer)

    End Function

    ReplyDelete
  4. Hey! This is just a prototype. You need to customize it as per your need. It worked for my application.
    NOTE: you might need minor tweaks.

    ReplyDelete

Post a Comment

Popular posts from this blog

redis server went away

It feels really awkward to see "redis: uncaught exception: Redis server went away" when it was working and suddenly this message bumps up. I faced the same situation while accessing php redis but I guess it's more generic one, more related to redis. So, here are possible solutions that I am able to find and highlighting the one which really did work for me.

1. /usr/sbin/setsebool httpd_can_network_connect=1


By default, SELinux does not allow Apache to make socket connections. So, enable the connection.

2. Try to stop the redis server and restart it again.
either of these two should work:
a) redis-cli
b) redis server

3. There might be issues with switch, try to use different switch.

error in eclipse on import org.eclipse.jetty.server.Server;

When you find error in line import org.eclipse.jetty.server.Server; it means eclipse doesn't contain jetty.jar. Right click on project -> properties on left pane -> java build path right pane -> add external jar under libraries tab link it to all the jar files of jetty folder. can download jetty from : http://www.eclipse.org/jetty/downloads.php now rebuild the project.