Insert hyperlink in a PowerPoint table cell with VBA - vba

Question

I'm working with PowerPoint 2007. I want to use a list to create a table on a slide. The first column of each row will have a hyperlink to a different slide in the presentation (like a summary slide).
I'm having trouble using VBA to insert a hyperlink into a cell. The error message is usually something like "object doesn't support that function".
Here is the offending line:
With pptPres.Slides(2).Shapes("Table Summary").Table.Cell(i - 1, 1).Shape.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = ThisWorkbook.Sheets(i).Range("B1")
.SubAddress = pptPres.Slides(i).SlideID
End With

Answer 1

You're almost there.
You need to access TextRange Object if you want to add a Link in the text within a table or shape.
Something like:
Sub marine()
Dim t As Table
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Set t = pptpres.Slides(1).Shapes(1).Table
With t.Cell(2, 1).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = "Link to Slide"
.SubAddress = pptpres.Slides(2).SlideNumber _
& ". " & pptpres.Slides(2).Name
End With
End Sub
And also, you cannot use SlideID property as SubAddress.
It should be in this format: <slide number><dot><space><slide name> (eg. #2. Slide2)
To get this done we used SlideNumber and Name property instead. HTH

Answer 2

thanks for the above. Below generates a hyperlinked TOC table for each slide into slide 2
Sub DeckTOC() ' Creates a hyperlinked TOC of each slide in deck
' Tip: add a return-to-TOC hyperlink on Slidemaster default layout
' assumes slide 1 is a cover slide, slides 2 is for TOC
' and #2 already includes a table And (important) no other shapes or title
' with col 1 for slide title and 2nd cloumn for slide no
' TOC can be formatted before/after macro has run
Dim slidecount As Integer
Dim t As Table
Dim TOCrow As Integer
Dim pptpres As Presentation
Set pptpres = ActivePresentation
slidecount = pptpres.Slides.Count
If slidecount < 3 Then Exit Sub ' nothing to do
Set t = pptpres.Slides(2).Shapes(1).Table ' grab= ther toc
TOCrow = 2
For i = 3 To slidecount Step 1 ' get slide references for each slide
If TOCrow > t.Rows.Count Then t.Rows.Add ' add rows on fly as needed
' create text entry in cell, then add hyperlink (doing in one step fails)
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange
.Text = pptpres.Slides(i).Shapes.Title.TextFrame.TextRange.Characters
End With
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange.Characters().ActionSettings(ppMouseClick).Hyperlink
.Address = ""
.SubAddress = pptpres.Slides(i).SlideNumber & ". " & pptpres.Slides(i).Name
End With
t.Cell(TOCrow, 2).Shape.TextFrame.TextRange.Text = i
TOCrow = TOCrow + 1
Next
End Sub
ex [enter image description here][1]
[1]: https://i.stack.imgur.com/gaMJK.png