单独与链接标题匹配的幻灯片单独链接的文本框的问题

Question

我整理了一个电子学习模块。我在vba还是很新。我正在尝试制作一个包含多个文本框的动态主菜单。如果文本框中的文本与幻灯片的标题匹配，则应将该形状超链接到相应的幻灯片。理想情况下，“主菜单”上的文本框应包含“部分”的名称以及指向已命名部分中第一张幻灯片的超链接，但我无法弄清楚这一点，因此我将每个部分中第一张幻灯片的标题与“文本。我一直在搜寻，并尽可能地靠近。我希望有人能帮助我完成它。我遇到了几个错误，并让文本超链接，但是所有链接都将用户带到演示文稿中的最后一张幻灯片，而不是正确的幻灯片。预先感谢您的指导！

代码如下：

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

这是修订的代码。我已经转了圈，现在陷入困境。任何建议，不胜感激！

恢复原始功能（FindSlideByTitle）后，我不断遇到错误，.textframe.textrange出现错误，使我认为在幻灯片上使用的形状类型（自由格式）需要TextFrame2，因此我进行了编辑可以解决该错误，但是从那以后，我一直无法使超链接正常工作，而是尝试通过包含父项来使用GoTo 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