Change Fill color using VBA in PowerPoint

[Paul_Hossler]

Best I can come up with

1. Insert hexagon shape on slide
2. Select it
3. Run macro Step1

4. Select a heptagon shape
5. Run macro Step2

Option Explicit
Dim oNewShape As Shape


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)
        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
    Dim oChangeShapeType 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    
    oChangeShapeType = oChangeShape.AutoShapeType    
    Set oPres = ActivePresentation    
    For Each oSlide In oPres.Slides
        For Each oShape In oSlide.Shapes
            If oShape.Type = msoAutoShape Then
                If oShape.AutoShapeType = oChangeShapeType Then
                    oShape.AutoShapeType = oNewShape.AutoShapeType
                End If
            End If
        Next
    Next
    Call MsgBox("Destination Shape type(s) Changed", vbOK + vbInformation, "Change Shapes")   
    oNewShape.Delete
End Sub