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