TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub UnderlineKeyText()

Dim oShp As Shape
Dim oSld As Slide
Dim oRng As TextRange
Dim SearchColor As Long
Dim ReplaceColor As Long
Dim x As Long
Dim y As Long

SearchColor = RGB(255, 0, 0)   ' Look for Red text
ReplaceColor = RGB(0, 0, 255) ' Make it pure blue
' Make ReplaceColor the same as SearchColor if you want the
' color of the underlines to end up the same

For Each oSld In ActivePresentation.Slides
    For Each oShp In oSld.Shapes
        If oShp.HasTextFrame Then
            ' It may still not have a text frame - or at least not an accessible one.  PPT lies sometimes.
            ' Then it throws errors if you try to touch the text frame it says the object has.  So:
            On Error Resume Next    ' ignore any errors
            If oShp.TextFrame.HasText Then
                Set oRng = oShp.TextFrame.TextRange
                For x = 1 To oRng.Runs.Count
                    If oRng.Runs(x).Font.Color.RGB = SearchColor Then
                        oRng.Runs(x).Font.Color.RGB = ReplaceColor
                        For y = 1 To oRng.Runs(x).Characters.Count
                            oRng.Runs(x).Characters(y).Text = "_"
                        Next
                        ' remove the font shadow, if any
                        oRng.Runs(x).Font.Shadow = False
                    End If
                Next x
            End If
            On Error GoTo 0   ' start paying attention to errors again
        End If
    Next oShp
Next oSld

End Sub