Convert slide titles to shapes to solve hyperlink limit problems

Problem

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.

Solution

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.

---