Powerpoint VBA to remove/replace/delete certain colored font in textbox and in tables

[lifelessons]

Hi all,

i am trying to write a VBA code to basically replace all instances of BLUE font in my power point and replace it with blanks/underscores.

so even if in a textbox/tablecell there're other colored fonts, it will replace only the BLUE ones.

So far it works perfectly fine with my textboxes, but i'm having trouble with the tablecells part. it only replaces if the ENTIRE cell is blue font. i can't get it to work like the textboxes.



this is my code... pardon the formatting, i'm just really bad at coding.

////
Sub delblue()
Dim oSld As Slide
Dim oShp As Shape
Dim x As Long
Dim i As Long
Dim j As Long


For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
With oShp.TextFrame.TextRange
For x = .Runs.Count To 1 Step -1
If .Runs(x).Font.Color.RGB = RGB(0, 0, 255) Then
.Runs(x).Text = "_____________"
.Runs(x).Font.Subscript = msoFalse
.Runs(x).Font.Superscript = msoFalse
End If
Next x
End With
End If 'has text

End If 'has textframe

If oShp.HasTable Then

For i = 1 To oShp.Table.Rows.Count
For j = 1 To oShp.Table.Columns.Count


If oShp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.T extRange.Font.Color.RGB = RGB(0, 0, 255) Then
oShp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.T extRange.Text = " "
oShp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.T extRange.Font.Subscript = msoFalse
oShp.Table.Rows.Item(i).Cells(j).Shape.TextFrame.T extRange.Font.Superscript = msoFalse


End If
Next j
Next i
End If
Next oShp
Next oSld
End Sub

////


would really appreciate any help here.. i've been stuck on this for days.. the ppt file that i have is just really huge and has many slides, so having this code will definitely help the processing time.

[JohnWilson]

See if this gets you started

Sub delblue()
   Dim oSld As Slide
   Dim oShp As Shape
   Dim x As Long
   Dim l As Long
   Dim i As Long
   Dim j As Long
   Dim otr As TextRange

   For Each oSld In ActivePresentation.Slides
      For Each oShp In oSld.Shapes
         If oShp.HasTextFrame Then
            If oShp.TextFrame.HasText Then
               With oShp.TextFrame.TextRange
                  For x = .Runs.Count To 1 Step -1
                     If .Runs(x).Font.Color.RGB = RGB(0, 0, 255) Then
                        Set otr = .Runs(x)
                        For l = 1 To otr.Length
                           otr.Characters(l) = "_"
                           otr.Font.Color.RGB = RGB(120, 120, 120)
                        Next l
                        .Runs(x).Font.Subscript = msoFalse
                        .Runs(x).Font.Superscript = msoFalse
                     End If
                  Next x
               End With
            End If      'has text
         End If      'has textframe
         If oShp.HasTable Then
            For i = 1 To oShp.Table.Rows.Count
               For j = 1 To oShp.Table.Columns.Count
                  If oShp.Table.Cell(i, j).Shape.TextFrame.HasText Then
                     With oShp.Table.Cell(i, j).Shape.TextFrame.TextRange
                        For x = .Runs.Count To 1 Step -1
                           If .Runs(x).Font.Color.RGB = RGB(0, 0, 255) Then
                              Set otr = .Runs(x)
                              For l = 1 To otr.Length
                                 otr.Characters(l) = "_"
                                 otr.Font.Color.RGB = RGB(120, 120, 120)
                              Next l
                              .Runs(x).Font.Subscript = msoFalse
                              .Runs(x).Font.Superscript = msoFalse
                           End If
                        Next x
                     End With
                    End If
                  Next j
               Next i
            End If
         Next oShp
      Next oSld
   End Sub

[lifelessons]

hi john,

thanks for your reply! i like it that the code changes the font to gray color as well.

there's a small issue, when there's a line break in the cell like

"numbers
123"

the word "numbers" get replaced by a "__" but the numbers "123" doesn't. it only gets grayed out.

and when running the code, powerpoint goes into "not responding" mode, but it becomes fine again after a while.

i'll try tweaking the code to see if i can incorporate yours into the one i currently have.

thanks!

[JohnWilson]

This would help but if you have equations they follow different rules and you may get unexpected results

Sub delblue()
   Dim oSld As Slide
   Dim oShp As Shape
   Dim x As Long
   Dim l As Long
   Dim i As Long
   Dim j As Long
   Dim otr As TextRange
   Dim otrTotal As TextRange

   For Each oSld In ActivePresentation.Slides
      For Each oShp In oSld.Shapes
         If oShp.HasTextFrame Then
            If oShp.TextFrame.HasText Then
               With oShp.TextFrame.TextRange
                  For x = .Runs.Count To 1 Step -1
                     If .Runs(x).Font.Color.RGB = RGB(0, 0, 255) Then
                        Set otr = .Runs(x)
                        For l = 1 To otr.Length
                            If otr.Characters(l).Font.Color.RGB = RGB(0, 0, 255) Then otr.Characters(l) = "_"
                           If otr.Characters(l) = "_" Then otr.Characters(l).Font.Color.RGB = RGB(120, 120, 120)
                        Next l
                        .Runs(x).Font.Subscript = msoFalse
                        .Runs(x).Font.Superscript = msoFalse
                     End If
                  Next x
               End With
            End If      'has text
         End If      'has textframe
         If oShp.HasTable Then
            For i = 1 To oShp.Table.Rows.Count
               For j = 1 To oShp.Table.Columns.Count
                  If oShp.Table.Cell(i, j).Shape.TextFrame.HasText Then
                  Set otrTotal = oShp.Table.Cell(i, j).Shape.TextFrame.TextRange
                     With otrTotal
                        For x = .Runs.Count To 1 Step -1
                           If .Runs(x).Font.Color.RGB = RGB(0, 0, 255) Then
                              Set otr = .Runs(x)
                              For l = 1 To otr.Length
                              If otrTotal.Paragraphs.Count > 1 Then
                              If Asc(otr.Characters(l)) = 13 Then
                              otr.Characters(l) = vbCrLf
                               Else
                                otr.Characters(l) = "_"
                                 If otr.Characters(l) = "_" Then otr.Characters(l).Font.Color.RGB = RGB(120, 120, 120)
                               End If
                               Else
                                If otr.Characters(l).Font.Color.RGB = RGB(0, 0, 255) Then otr.Characters(l) = "_"
                                 If otr.Characters(l) = "_" Then otr.Characters(l).Font.Color.RGB = RGB(120, 120, 120)
                               End If
                              Next l
                              .Runs(x).Font.Subscript = msoFalse
                              .Runs(x).Font.Superscript = msoFalse
                           End If
                        Next x
                     End With
                    End If
                  Next j
               Next i
            End If
         Next oShp
      Next oSld
   End Sub