vba - 将多个超链接添加到 PowerPoint 形状

Question

任务:我有一个 PowerPoint 文件，其中包含带有文本的幻灯片。文本包含代码字，我想将其替换为超链接。现在我正在使用下面的代码来实现这一点。

For Each sld In prt.Slides
  For Each shp In sld.Shapes
    If shp.HasTextFrame Then
      If shp.TextFrame.HasText Then

        Set rngToSearch = shp.TextFrame.TextRange
        Set rngFound = rngToSearch.Find("SomeLink")

        Do While Not (rngFound Is Nothing)
            With rngFound

                With .ActionSettings(ppMouseClick)
                    .Action = ppActionHyperlink
                    .Hyperlink.Address = "http://www.SomeLink.de"
                    .Hyperlink.TextToDisplay = "SomeLink"
                End With

                .Font.Bold = msoFalse

                Set rngFound = rngToSearch.Find("SomeLink", .Start + .Length - 1)

            End With
        Loop

      End If
    End If
  Next shp
Next sld

有效方法:代码设法找到代码字 SomeLink 的所有出现，并且使该单词的每个出现都变为粗体(我这样做只是为了测试目的) 。这告诉我，变量 rngFound 工作正常(即设置为每个 TextFrame 文本的右侧子部分。

什么不起作用:代码不是为形状中的每个代码字创建超链接，而是仅采用找到代码字的每个形状的第一个单词并创建超链接。下面的图片显示了之前和之后的情况，以便更清楚地说明这一点。

之前:

之后:

问题:有人知道如何使这段代码按预期运行吗？我现在真的吓坏了。

Answer 1

解决了，但我认为这很有趣，所以我不会只是删除问题，而是实际上给出答案。所以下面的代码就达到了目的。

For Each sld In prt.Slides
  For Each shp In sld.Shapes
    If shp.HasTextFrame Then
      If shp.TextFrame.HasText Then

        Set rngToSearch = shp.TextFrame.TextRange
        Set rngFound = rngToSearch.Find("SomeLink")

        Do While Not (rngFound Is Nothing)
            With rngFound

                rngFound.Text = "SomeLink"

                With .ActionSettings(ppMouseClick)
                    .Action = ppActionHyperlink
                    .Hyperlink.Address = "http://www.SomeLink.de"
                End With

                Set rngFound = rngToSearch.Find("SomeLink", .Start + .Length - 1)

            End With
        Loop

      End If
    End If
  Next shp
Next sld

我改变了什么？嗯，基本上只有两行!我的错误是 .Hyperlink.TextToDisplay = "SomeLink" 行。这在某种程度上扰乱了 Textrange。相反，我现在首先使用新行 rngFound.Text = "SomeLink" 更改找到的 Textrange 的文本，然后创建超链接。