Issues with Textboxes Individually Hyperlinked to Slide with Matching Titles - vba

Question

I have put together an e-learning module. I am still very new at vba though. I am trying to make a dynamic main menu which contains multiple text boxes. If the text in a text box matches the title of a slide, that shape should then then be hyperlinked to the corresponding slide. Ideally, the text boxes on the Main Menu would contain the names of Sections and hyperlink to the first slide in the named section, but I couldn't figure that out, so instead I made the title of the first slide in each section match the text. I've searched and searched and gotten as close as I could. I am hoping someone can help me finish it. I have gotten past several errors, and have the text hyperlinked, however all linked take the user to the last slide in the presentation instead of the proper slide. Thank you in advance for any guidance!!
Here is the code:
Sub TestMe()
'Original Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim aSl As Slide 'active slide
Dim dSl As Slide 'destination slide
Dim Slde As Slide
Dim oSh As Shape
Dim aSl_ID As Integer
Dim aSl_Index As Integer
Dim dSl_ID As Integer
Dim dSl_Index As Integer
Dim sTextToFind As String
Dim hypstart As String
Dim Titl As String
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
' Set ActiveSld_Index =
' Set DestinationSld_ID = oSl.SlideID
' Set DestinationSld_Index = oSl.SlideIndex
For Each oSh In aSl.Shapes
'If IsSafeToTouchText(oSh) = True Then
sTextToFind = oSh.TextFrame.TextRange.Text
'loop through slides looking for a title that matches the text box value
On Error Resume Next
Set dSl = FindSlideByTitle(sTextToFind)
' get the information required for the hyperlink
dSl_ID = CStr(dSl.SlideID)
dSl_Index = CStr(dSl.SlideIndex)
' find the text string in the body
hypstart = InStr(1, sTextToFind, sTextToFind, 1)
'make the text a hyperlink
With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
End With
'End If
Next oSh
End Sub
Public Function FindSlideByTitle(sTextToFind As String) As Slide
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
Dim oSl As Slide
Dim oSh As Shape
With ActivePresentation
For Each oSl In .Slides
For Each oSh In oSl.Shapes
With oSh
'If .HasTextFrame Then
'If Not .TextFrame.TextRange.Text Is Nothing Then
'myPres.Slides(1).Shapes.Title.TextFrame.TextRange
On Error Resume Next
If UCase(.TextFrame.TextRange.Text) = UCase(sTextToFind) Then
'If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle = oSl
'End If
End If
'End If
End With
Next
Next
End With
End Function
Public Function IsSafeToTouchText(pShape As Shape) As Boolean
'Source: http://www.steverindsberg.com/pptlive/FAQ00056.htm
On Error GoTo ErrorHandler
If pShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
' Errors here if it's a bogus shape:
If Len(pShape.TextFrame.TextRange.Text) > 0 Then
' it's safe to touch it
IsSafeToTouchText = True
Exit Function
End If ' Length > 0
End If ' HasText
End If ' HasTextFrame
Normal_Exit:
IsSafeToTouchText = False
Exit Function
ErrorHandler:
IsSafeToTouchText = False
Exit Function
End Function
Here is the revised code. I have gone in circles and am now stuck. Any suggestions are much appreciated!
After I restored the original function (FindSlideByTitle), I kept getting an error on got an error on .textframe.textrange, making me think that the type of shape I used on my slide (freeform) needed TextFrame2, so I edited that, which fixed the error, but since then I've not been able to make the hyperlink work and have tried instead to use GoTo Slide by including the parent.
I even tried making an array of all freeform shapes on the slide, but I'm still new at this and perhaps I don't fully understand the concepts yet. As it currently stands, I don't get any errors, however, when I click one of the shapes, the shape's appearance changes from the click, but it doesn't go anywhere.
I have also included an image of the actual slide.
Sub TestLinkShapesToSlideTitles()
Dim aSl, dSl, oSl As Slide 'active slide, destination slide
Dim oSh As PowerPoint.Shape
Dim aSl_ID, dSl_ID As Integer
Dim aSl_Index, dSl_Index As Long
Dim dSl_Title, hypstart, Titl As String
Dim sTextToFind As String
Dim numshapes, numFreeformShapes As Long
Dim FreeformShpArray As Variant
Dim ShpRange As Object
Dim oPres As Presentation
Set aSl = Application.ActiveWindow.View.Slide 'active slide
aSl_Index = Application.ActiveWindow.View.Slide.SlideIndex 'active slide index
''''''''''''''''''''''''''''
'In this section I tried to make an array of all the freeform shapes on the slide, thinking that would help.
With aSl.Shapes
numshapes = .Count
'Continues if there are Freeform shapes on the slide
If numshapes > 1 Then
numFreeformShapes = 0
ReDim FreeformShpArray(1 To numshapes)
For i = 1 To numshapes
'Counts the number of Freeform Shapes on the Slide
If .Item(i).Type = msoFreeformShape Then
numFreeformShapes = numFreeformShapes + 1
FreeformShpArray(numFreeformShapes) = .Item(i).Name
End If
Next
'Adds Freeform Shapes to ShapeRange
If numFreeformShapes > 1 Then
ReDim Preserve FreeformShpArray(1 To numFreeformShapes)
Set ShpRange = .Range(FreeformShpArray)
'asRange.Distribute msoDistributeHorizontally, False
End If
End If
End With
''''''''''''''''''''''''''
On Error Resume Next
'Loop through all the shapes on the active slide
For Each oSh In aSl.Shapes
If oSh.Type = msoFreeform Then 'oSh.Type = 5
'If oSh.HasTextFrame Then
If oSh.TextFrame2.HasText Then 'results in -1
With oSh
sTextToFind = .TextFrame2.TextRange.Characters
'sTextToFind results in "Where to Begin"
'.TextFrame2.TextRange.Characters results in "Learn the Lingo", which is the shape after Where to Begin.
End With
End If
'End If
'If IsSafeToTouchText(oSh) = True Then
'With oSh.TextFrame
'sTextToFind = .TextRange.Characters.Text
'loop through slides looking for a title that matches the text box value
'For Each oSl In ActivePresentation.Slides
'If oSl.Shapes.HasTitle Then
'Titl = Slde.Shapes.Title.TextFrame.TextRange <<<<< I kept getting the error here...
On Error Resume Next
Set dSl = FindSlideByTitle_Original(sTextToFind)
' get the information required for the hyperlink
dSl_Title = dSl.Shapes.Title.TextFrame.TextRange
dSl_ID = dSl.SlideID
dSl_Index = dSl.SlideIndex
With oSh
.ActionSettings(ppMouseClick).Parent.Parent.View.GoToSlide dSl_Index, msoFalse 'Go to slide and don't reset animations
End With
' find the text string in the body
'hypstart = InStr(1, sTextToFind, dSl_Title, 1)
'make the text a hyperlink
'With oSh.TextFrame.TextRange.Characters(hypstart, Len(sTextToFind)).ActionSettings(ppMouseClick).Hyperlink
'.SubAddress = dSl_ID & "," & dSl_Index & "," & sTextToFind
'End With
'End With
End If
'End If
Next oSh
End Sub
Public Function FindSlideByTitle_Original(sTextToFind As String) As Slide
'Source: https://stackoverflow.com/questions/25038952/vba-powerpoint-select-a-slide-by-name
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If UCase(.TextRange.Text) = UCase(sTextToFind) Then
Set FindSlideByTitle_Original = oSl
End If
End If
End With
Next
End Function