在MS PowerPoint中查找并突出显示文本

Question

我使用本网站的一些代码来制作一个宏，在Word文档上进行关键字搜索并突出显示结果。

我想在PowerPoint中复制效果。

这是我的Word代码。

Sub HighlightKeywords() 

Dim range As range 
Dim i As Long 
Dim TargetList 

TargetList = Array("keyword", "second", "third", "etc") ' array of terms to search for 

For i = 0 To UBound(TargetList) ' for the length of the array 

    Set range = ActiveDocument.range 

    With range.Find ' find text withing the range "active document" 
    .Text = TargetList(i) ' that has the words from the array TargetList 
    .Format = True ' with the same format 
    .MatchCase = False ' and is case insensitive 
    .MatchWholeWord = True ' and is not part of a larger word 
    .MatchAllWordForms = False ' and DO NOT search for all permutations of the word 

    Do While .Execute(Forward:=True) 
    range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow 

    Loop 

    End With 
Next 

End Sub 

这是我到目前为止在PowerPoint中，它没有任何功能。

Sub HighlightKeywords() 

Dim range As range 
Dim i As Long 
Dim TargetList 

TargetList = Array("keyword", "second", "third", "etc") ' array of terms to search for 

For Each sld In Application.ActivePresentation.Slides 

For Each shp In sld.Shapes 

    If shp.HasTextFrame Then 

     Set txtRng = shp.TextFrame.TextRange 

For i = 0 To UBound(TargetList) ' for the length of the array 

    With range.txtRng ' find text withing the range "shape, text frame, text range" 
    .Text = TargetList(i) ' that has the words from the array TargetList 
    .Format = True ' with the same format 
    .MatchCase = False ' and is case insensitive 
    .MatchWholeWord = True ' and is not part of a larger word 
    .MatchAllWordForms = False ' and DO NOT search for all permutations of the word 

    Do While .Execute(Forward:=True) 
    range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow 

    Loop 

    End With 
Next 

End Sub 

---

我最终通过MSDN找到我的答案，但它是非常接近的，我选择从人提交的内容为正确答案。

这里是我去的代码：

Sub Keywords() 

Dim TargetList 
Dim element As Variant 

TargetList = Array("First", "Second", "Third", "Etc") 

For Each element In TargetList 
    For Each sld In Application.ActivePresentation.Slides 
     For Each shp In sld.Shapes 
     If shp.HasTextFrame Then 
      Set txtRng = shp.TextFrame.TextRange 
      Set foundText = txtRng.Find(FindWhat:=element, MatchCase:=False, WholeWords:=True) 
      Do While Not (foundText Is Nothing) 
       With foundText 
        .Font.Bold = True 
        .Font.Color.RGB = RGB(255, 0, 0) 
       End With 
      Loop 
     End If 
     Next 
    Next 
Next element 

End Sub 

---

原来，代码工作，但性能噩梦。我在下面选择的正确答案的代码运行得更顺利。我调整了我的程序以匹配选定的答案。

Answer 1

AFAIK没有内置的方式突出显示找到的颜色字。你可以用它来创建一个矩形的形状，并将其放置在找到的文本后面并着色，但这完全是一个不同的球类游戏。

下面是一个例子，它将搜索所有幻灯片中的文本，然后使找到的文本BOLD，UNDERLINE和ITALICIZED。如果你想要，你也可以改变字体的颜色。

比方说，我们有一个幻灯片，看起来像这样

一个模块在此代码粘贴，然后尝试。我已经评论了该代码，以便您不会理解它。

Option Explicit 

Sub HighlightKeywords() 
    Dim sld As Slide 
    Dim shp As Shape 
    Dim txtRng As TextRange, rngFound As TextRange 
    Dim i As Long, n As Long 
    Dim TargetList 

    '~~> Array of terms to search for 
    TargetList = Array("keyword", "second", "third", "etc") 

    '~~> Loop through each slide 
    For Each sld In Application.ActivePresentation.Slides 
     '~~> Loop through each shape 
     For Each shp In sld.Shapes 
      '~~> Check if it has text 
      If shp.HasTextFrame Then 
       Set txtRng = shp.TextFrame.TextRange 

       For i = 0 To UBound(TargetList) 
        '~~> Find the text 
        Set rngFound = txtRng.Find(TargetList(i)) 

        '~~~> If found 
        Do While Not rngFound Is Nothing 
         '~~> Set the marker so that the next find starts from here 
         n = rngFound.Start + 1 
         '~~> Chnage attributes 
         With rngFound.Font 
          .Bold = msoTrue 
          .Underline = msoTrue 
          .Italic = msoTrue 
          '~~> Find Next instance 
          Set rngFound = txtRng.Find(TargetList(i), n) 
         End With 
        Loop 
       Next 
      End If 
     Next 
    Next 
End Sub 

最后截图

Answer 2

我想延长@Siddharth溃败的答案，这是很好，相当推荐（awarder +1从我）。但是，也有可能在PP中“突出显示”一个词（词的范围）。设置高亮有一个严重的缺点 - 它会破坏其他字体设置。因此，如果真的需要使用高亮度，则需要事后返回适当的字体设置。

下面是在单个文本框单个单词的一个示例：

Sub Highlight_Word() 

Dim startSize, startFont, startColor 

With ActivePresentation.Slides(1).Shapes(1).TextFrame2.TextRange.Words(8).Font 
'read current state 
    startSize = .Size 
    startFont = .Name 
    startColor = .Fill.ForeColor.RGB 

'set highlight 
    .Highlight.RGB = RGB(223, 223, 223) 'light grey 

'return standard parameters 
    .Size = startSize 
    .Name = startFont 
    .Fill.ForeColor.RGB = startColor 

End With 

End Sub 

这种溶液可以某处放置@Siddharth溶液内。

Answer 3

如果你需要完全保留原始文本格式，您可以：

找到一个形状，包括目标文本， 复制形状 发送复制到原来的形状的Z-为了 待办事项重复形状上的突出显示 将标签应用于复制品和原件以表明他们稍后需要注意 例如 oOriginalShape.Tags.Add“高亮显示了”，“原始” oDupeShape.Tags.Add“高亮显示了”，“复制”

将原来的形状无形

然后，如果你需要扭转的高亮和恢复原格式化，你只需循环遍历所有形状;如果形状的Hilighting标签=“原始”，使其可见。如果它有Higlighting标记=“重复”，请删除它。

这里的顺序是，如果某人编辑了突出显示的形状，则在您恢复时编辑将会丢失。用户将不得不被教导恢复，编辑，然后重新突出显示。