问题
I used some code from this site to make a macro to do a keyword search on Word docs and highlight the results.
I would like to replicate the effect in PowerPoint.
Here is my code for 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
Here is what I have so far in PowerPoint, it is in no way functional.
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
I ended up finding my answer through the MSDN, but it was very close to the answer I selected as correct from what people submitted.
Here is the code I went with:
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
Turns out that code worked, but was a performance nightmare. The code I selected as the correct answer below runs much more smoothly. I've adjusted my program to match the answer selected.
回答1:
AFAIK there is no inbuilt way to highlight the found word with a color. You could go out of the way to create a rectangular shape and place it behind the found text and color it but that is a different ball game altogether.
Here is an example which will search for the text in all slides and then make the found text BOLD, UNDERLINE and ITALICIZED. If you want you can also change the color of the font.
Let's say we have a slide which looks like this
Paste this code in a module and then try it. I have commented the code so that you will not have a problem understanding it.
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
Final Screenshot
回答2:
I'd like to extend @Siddharth Rout answer which is good and rather recommended (awarder +1 from me). However, there is possibility to 'highlight' a word (range of words) in PP, too. There is one serious disadvantage of setting highlight- it destroys other font settings. Therefore, if one really need to use highlight than we need to return appropriate font settings afterwards.
Here is an example for single word in single text frame:
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
That kind of solution could be placed somewhere inside of @Siddharth solution.
回答3:
And if you need to preserve the original text formatting completely, you could:
On finding a shape that includes the target text, Duplicate the shape Send the duplicate to the original shape's Z-order Do the highlighting on the duplicate shape Apply tags to both the duplicate and original to indicate that they need attention later e.g. oOriginalShape.Tags.Add "Hilighting", "Original" oDupeShape.Tags.Add "Hilighting", "Duplicate"
Set the original shape invisible
Then if you need to reverse the highlighting and restore original formatting, you'd simply loop through all shapes; if the shape has a Hilighting tag = "Original", make it visible. If it has Higlighting tag = "Duplicate", delete it.
The hitch here is that if somebody's edited the highlighted shape, the edits will be lost when you revert. Users would have to be taught to revert, edit, then re=highlight.
来源：https://stackoverflow.com/questions/15844903/find-and-highlight-text-in-ms-powerpoint