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

How to do mass insert in redis

A basic and fairly easy way to do mass insert in redis:

Command to use: echo -e "$(cat redis_mass_insert.txt)" | redis-cli --pipe
Content of file "redis_mass_insert.txt": *3\r\n$5\r\nlpush\r\n$5\r\nu:m:1\r\n$5\r\nvalu1\r\n*3\r\n$5\r\nlpush\r\n$5\r\nu:m:1\r\n$7\r\nmyvalue\r\n

Result: All data transferred. Waiting for the last reply...
ERR unknown command ' *2'
ERR unknown command '$4'
ERR wrong number of arguments for 'echo' command
ERR unknown command '$20'
ERR unknown command ' A�j d�Q;yT��าก �h>'


NOTE: command line will show error but in actual the data is transferred and you can check it by entering in redis.

Here's the snapshot of the whole procedure:




To check how the command is responding: use hexdump -C
Command: echo -n $'$3\r\nset\r\n$3\r\nkey\r\n$5\r\nvalue\r\n ' | hexdump -C
whose output will be something like
00000000 24 33 0d 0a 73 65 74 0d 0a 24 33 0d 0a 6b 65 79 |$3..set..$3..key|
00000010 0d 0a…

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.