VBA Code


Easy to find and replace one colour or formatting with another one


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



© 2020 Better Solutions Limited. All Rights Reserved. © 2020 Better Solutions Limited TopPrev