Encuentra y resalta texto en MS PowerPoint
Usé algo de código de este sitio para hacer una macro para hacer una búsqueda por palabra clave en documentos de Word y resaltar los resultados.
Me gustaría replicar el efecto en PowerPoint.
Aquí está mi código para 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
Esto es lo que tengo hasta ahora en PowerPoint, de ninguna manera es funcional.
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
Terminé encontrando mi respuesta a través de MSDN, pero fue muy cercana a la respuesta que seleccioné como correcta de lo que las personas enviaron.
Aquí está el código con el que fui:
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
Resulta que el código funcionó, pero fue una pesadilla de rendimiento. El código que seleccioné como la respuesta correcta a continuación funciona mucho más suavemente. He ajustado mi programa para que coincida con la respuesta seleccionada.