OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

While it is easy to replace one color with another if color schemes are used, the same cannot be said if the colors have been manually changed to another. The routine below, lets you do that. You can locate a particular color and replace it with the desired one for text, fills or borders of a shape.

' ---------------------------------------------------------------------
' Copyright ©1999-2018 Shyam Pillai. All Rights Reserved.
' ---------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or 
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' ---------------------------------------------------------------------

Option Explicit
Sub RecolourShapes()
Dim oSld As Slide
Dim oShp As Shape
Dim I As Integer
For Each oSld In ActivePresentation.Slides
    For Each oShp In oSld.Shapes
        If oShp.Type = msoGroup Then
            For I = 1 To oShp.GroupItems.Count
                Call FindAndReColourText(oShp.GroupItems(I), _
                        RGB(100, 100, 100), RGB(255, 0, 255))
                Call FindAndReColourFill(oShp.GroupItems(I), _
                        RGB(255, 255, 255), RGB(255, 0, 255))
                Call FindAndReColourBorder(oShp.GroupItems(I), _
                        RGB(100, 100, 100), RGB(255, 0, 255))
            Next I
        Else
            Call FindAndReColourText(oShp, _
                        RGB(100, 100, 100), RGB(255, 0, 255))
            Call FindAndReColourFill(oShp, _
                        RGB(255, 255, 255), RGB(255, 0, 255))
            Call FindAndReColourBorder(oShp, _
                        RGB(100, 100, 100), RGB(255, 0, 255))
        End If
    Next oShp
Next oSld
End Sub

Function FindAndReColourText(oShp As Shape, _
                            oRGB As Long, oNewRGB As Long)
Dim I As Integer
Dim oTxtRng As TextRange
On Error Resume Next
If oShp.HasTextFrame Then
    If oShp.TextFrame.HasText Then
        Set oTxtRng = oShp.TextFrame.TextRange
        For I = 1 To oTxtRng.Runs.Count
            With oTxtRng.Runs(I).Font.Color
                If .Type = msoColorTypeRGB Then
                    If .RGB = oRGB Then
                        .RGB = oNewRGB
                    End If
                End If
            End With
        Next I
    End If
End If
End Function
Function FindAndReColourFill(oShp As Shape, _
                        oRGB As Long, oNewRGB As Long)
On Error Resume Next
If oShp.Fill.Visible Then
    If oShp.Fill.ForeColor.RGB = oRGB Then
        oShp.Fill.ForeColor.RGB = oNewRGB
    End If
End If
End Function
Function FindAndReColourBorder(oShp As Shape, _
                        oRGB As Long, oNewRGB As Long)
On Error Resume Next
If oShp.Line.Visible Then
    If oShp.Line.ForeColor.RGB = oRGB Then
        oShp.Line.ForeColor.RGB = oNewRGB
    End If
End If
End Function