Change Fill color using VBA in PowerPoint

[Paul_Hossler]

Some changes to Step2

Slide 2 has a Group

Option Explicit
Dim oNewShape As Shape
Dim tNewType As MsoAutoShapeType

Sub Step1()
    If MsgBox("This is Step1 of a two step process" & vbCrLf & vbCrLf & _
        "1. You must already have inserted and selected a new Shape to change to" & vbCrLf & _
        "2. After running, Step1 will remember the new type of shape" & vbCrLf & _
        "3. Select one of the shapes to be changed" & vbCrLf & _
        "4. Run the Step2 Macro", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub    
    Set oNewShape = Nothing
    On Error Resume Next
    Set oNewShape = ActiveWindow.Selection.ShapeRange(1)
    tNewType = oNewShape.AutoShapeType
    On Error GoTo 0    
    If oNewShape Is Nothing Then
        Call MsgBox("You must select an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
        Exit Sub
    End If    
    If oNewShape.Type <> msoAutoShape Then
        Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
        Exit Sub
    End If
    Call MsgBox("Destination Shape type memorized", vbOK + vbInformation, "Change Shapes")
End Sub


Sub Step2()
    Dim oPres As Presentation
    Dim oSlide As Slide
    Dim oShape As Shape, oChangeShape As Shape, oShapeInGroup As Shape
    Dim tCurrentType As MsoAutoShapeType    
    If MsgBox("This is Step2 of a two step process" & vbCrLf & vbCrLf & _
        "1. You must already have selected an instance of a Shape to change" & vbCrLf & _
        "2. All instances on all slides of that type of Shape will be changes", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then Exit Sub    
    If oNewShape Is Nothing Then
        Call MsgBox("1. You must select an example of a new AutoShape to change the shapes to" & vbCrLf & _
            "2. Re-run Step1", vbCritical + vbOKOnly, "Change Shapes")
        Exit Sub
    End If    
    Set oChangeShape = Nothing
    On Error Resume Next
    Set oChangeShape = ActiveWindow.Selection.ShapeRange(1)
    On Error GoTo 0    
    If oChangeShape Is Nothing Then
        Call MsgBox("You must select an AutoShape of the type to be changed", vbCritical + vbOKOnly, "Change Shapes")
        Exit Sub
    End If    
    If oChangeShape.Type <> msoAutoShape Then
        Call MsgBox("The selected Shape must be an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
        Exit Sub
    End If    
    tCurrentType = oChangeShape.AutoShapeType    
    Set oPres = ActivePresentation    
    For Each oSlide In oPres.Slides
        For Each oShape In oSlide.Shapes
            If oShape.Type = msoGroup Then
                For Each oShapeInGroup In oShape.GroupItems
                    Call pvtChangeAutoShapeType(oShapeInGroup, tCurrentType, tNewType)
                Next           
            Else
                Call pvtChangeAutoShapeType(oShape, tCurrentType, tNewType)
            End If
        Next
    Next
    oNewShape.Delete
End Sub


Private Sub pvtChangeAutoShapeType(o As Shape, tCurrent As MsoAutoShapeType, tNew As MsoAutoShapeType)
    With o
        If .Type <> msoAutoShape Then Exit Sub
        If .AutoShapeType <> tCurrent Then Exit Sub
        .AutoShapeType = tNew
    End With
End Sub