Convert slide titles to shapes to solve hyperlink limit problems
As described elsewhere in this FAQ, PowerPoint has a fixed limit upper limit on the amount of link information it can store. Once you exceed those limits, your links start acting crazy. They're liable to disappear or point to the wrong places.
One contributing factor can be the length of your slide titles; these become part of the information PowerPoint stores in its hyperlinks collection. The shorter your titles, the more links you can store.
This routine makes copies of all your slide titles (so they appear not to change at all) but replaces the actual title with much shorter text ( S-xx, where xx is the slide number). It then replaces all of the previous title text in your slide links with the new short version.
NEVER run this on your original presentation. ALWAYS run it on a copy of your work.
Sub TitlesToText() ' Converts titles to text shapes then changes titles to something short ' in order to help solve hyperlink problems due to over-long/too-many titles Dim oSlide As Slide Dim oSlides As Slides Dim oShapes As Shapes Dim oSh As Shape Dim oHyperlinks As Hyperlinks Dim oHl As Hyperlink Dim tmpText1 As String Dim tmpText2 As String Set oSlides = ActivePresentation.Slides For Each oSlide In oSlides ' Deal with the titles: Set oShapes = oSlide.Shapes For Each oSh In oShapes If oSh.Type = msoPlaceholder Then If oSh.HasTextFrame Then If oSh.TextFrame.HasText Then If oSh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Or _ oSh.PlaceholderFormat.Type = ppPlaceholderTitle Then ' make a copy of the title and move it to match title's position With oSh.Duplicate .Top = oSh.Top .Left = oSh.Left .Tags.Add "OriginalTitleText", oSh.TextFrame.TextRange.Text End With ' change the title text to something innocuous (and SHORT) ' or leave it as is, but remove the commas ' remove the ' from one or the other of the following lines ' to choose which: 'oSh.TextFrame.TextRange.Text = "S-" & CStr(oSlide.SlideIndex) oSh.TextFrame.TextRange.Text = _ Replace(oSh.TextFrame.TextRange.Text, ",", " ") ' and hide it oSh.Visible = msoFalse End If End If End If End If Next oSh ' fix up hyperlinks Set oHyperlinks = oSlide.Hyperlinks For Each oHl In oHyperlinks If oHl.Address = "" And oHl.SubAddress <> "" Then If InStr(oHl.SubAddress, ",") > 0 Then tmpText1 = oHl.SubAddress ' xx,yy,This is the old title ' get the text up to and including the first comma tmpText2 = Mid$(tmpText1, 1, InStr(tmpText1, ",")) ' xx, ' strip off the text we just grabbed tmpText1 = Right$(tmpText1, Len(tmpText1) - Len(tmpText2)) ' yy,This is the old title ' Get the text up to and including the first comma, append it tmpText2 = tmpText2 & Mid$(tmpText1, 1, InStr(tmpText1, ",")) ' append a null tmpText2 = tmpText2 & " " oHl.SubAddress = tmpText2 End If End If Next oHl Next oSlide Set oSlide = Nothing Set oSlides = Nothing End Sub
To get a report of the slides in the presentation plus the original titles (as opposed to the new short ones), you can use this:
Sub GatherTitles() ' This is a modified version of the GatherTitles macro ' that collects the original title text stored in tags ' by our TitlesToText macro Dim oSlide As Slide Dim strTitles As String Dim strFilename As String Dim intFileNum As Integer Dim PathSep As String If ActivePresentation.Path = "" Then MsgBox "Please save the presentation then try again" Exit Sub End If #If Mac Then PathSep = ":" #Else PathSep = "\" #End If For Each oSlide In ActiveWindow.Presentation.Slides On Error Resume Next ' in case the title shape's gone missing strTitles = strTitles _ & "Slide: " _ & CStr(oSlide.SlideIndex) & vbCrLf _ & oSlide.Shapes("PseudoTitle").Tags("OriginalTitleText") _ & vbCrLf & vbCrLf Next oSlide intFileNum = FreeFile ' PC-Centricity Alert! ' This assumes that the file has a .PPT extension and strips it off to make the text file name. strFilename = ActivePresentation.Path _ & PathSep _ & Mid$(ActivePresentation.Name, 1, Len(ActivePresentation.Name) - 4) _ & "_Titles.TXT" Open strFilename For Output As intFileNum Print #intFileNum, strTitles Close intFileNum Call Shell("Notepad " & strFilename, vbNormalFocus) End Sub
See How do I use VBA code in PowerPoint? to learn how to use this example code.