在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標記=「重複」，請刪除它。

這裏的順序是，如果某人編輯了突出顯示的形狀，則在您恢復時編輯將會丟失。用戶將不得不被教導恢復，編輯，然後重新突出顯示。