Change Fill color using VBA in PowerPoint

[dibyendu2280]

I have 10 hexagon shape(having other shape also ie rectangle, square) & having four animation(Entrance:Appear, Motion paths : down, Emphasis:Fill color(given Blue color), Motion paths:Left) with fixed delay.
During starting animation(during entrance) hexagon color is Red & when meet emphasis animation it become Blue color & remain Blue for remaining animations.
Now I want to change both color through VBA code. I am abale to change only entrance color(ie Red to my coustom color) through below code:

Sub addColorhexagon()


 Dim hshp As Shape
 Dim osld As Slide
 Dim r As Long
 Dim g As Long
 Dim b As Long
 On Error Resume Next


r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")


 Set osld = ActivePresentation.Slides(1)


 For j = 1 To 10


 Set hshp = osld.Shapes("hexagon" & j)
 hshp.Fill.ForeColor.RGB = RGB(r, g, b)
 hshp.Fill.Solid
 Next j
 On Error GoTo errhandler
Exit Sub
errhandler:
MsgBox "Opps!"


End Sub

So How can I change the Blue color (Emphasis:Fill color ie Blue) to my custom color?
Please help

[Paul_Hossler]

1. Don't put On Error Resume Next as the first thing. You need to see the error to correct them
Only use it in specific places where you KNOW it's OK to ignore an error

2. The shape's default name is "Hexagon<space>3", etc.
Unless you renamed them, no shape would match

3. If you just want to make all the hexagons blue, there's better, more robust ways to to it that doesn't require match names, etc.
See the second version

Option Explicit


Sub addColorhexagon()
    Dim hshp As Shape
    Dim osld As Slide
    Dim j As Long
    Dim r As Long
    Dim g As Long
    Dim b As Long


    r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
    g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
    b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")


    Set osld = ActivePresentation.Slides(1)


    'testing
    osld.Shapes("Hexagon 3").Fill.ForeColor.RGB = RGB(r, g, b)
 
'    On Error Resume Next
'    For j = 1 To 10
'        Set hshp = osld.Shapes("hexagon" & j)
'        hshp.Fill.ForeColor.RGB = RGB(r, g, b)
'        hshp.Fill.Solid
'    Next j
'    On Error GoTo 0


End Sub

Sub addColorhexagon_1()
    Dim oPres As Presentation
    Dim oShape As Shape
    Dim oSlide As Slide
    Dim j As Long
    Dim r As Long
    Dim g As Long
    Dim b As Long


    r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
    g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
    b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")




    Set oPres = ActivePresentation
        
    For Each oSlide In oPres.Slides
        For Each oShape In oSlide.Shapes
            If oShape.Type = msoAutoShape Then
                If oShape.AutoShapeType = msoShapeHexagon Then
                    oShape.Fill.ForeColor.RGB = RGB(r, g, b)
                End If
            End If
        Next
    Next


End Sub

[dibyendu2280]

Thanks Sir @Paul_Hossler
The above both codes are working fine to make the Hexagon shape(red color) to any custom color before the start of Emphasis:Fill color(given Blue color) animation.
So when the Emphasis:Fill color animation starts it changes to its original Blue color & remain blue for the end. Actually I wanted to change that fill color (blue) to any custom color.
Thanks again sir to make an interest to solve my problem

[Paul_Hossler]

If the above doesn't work for you, then I'm not understanding

Attach a small presentation and add detailed instructions/examples, then I'll look again

[dibyendu2280]

Thanks Sir @Paul_Hossler
I am attached a small presentation where I want to change Blue color to any custom color.
With the help of above two code which u provided Red color changes to any custom color(solved).

Note: I name shape "hexagon1" to "Heptagon1", "Heptagon2" "Heptagon3".....in PowerPoint presentation ie in example.pptx

[Paul_Hossler]

This is what you requested, but I'm not sure it's what you need

where I want to change Blue color to any custom color.

There were no blue shapes in your example, so I made them blue

Capture.JPG

Option Explicit


Sub test()
    Dim hshp As Shape
    Dim osld As Slide
    Dim j As Long
    Dim r As Long
    Dim g As Long
    Dim b As Long




    r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
    g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
    b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")




    Set osld = ActivePresentation.Slides(1)
    On Error Resume Next
    For j = 1 To 10
        Set hshp = osld.Shapes("Heptagon" & j)
        If hshp.Fill.ForeColor.RGB = RGB(0, 0, 255) Then
            hshp.Fill.ForeColor.RGB = RGB(r, g, b)
            hshp.Fill.Solid
        End If
    Next j
    On Error GoTo 0


End Sub

[dibyendu2280]

Thanks Sir @Paul_Hossler
Sir run the presentation this red shape turn into blue & remains blue till the end.I want to change that blue color.
Thanks again sir.

[Paul_Hossler]

Sorry, when I started the slide show, all I saw was the background. When I clicked, it ended. I did not wait long enough

Option Explicit
Sub test()
    Dim j As Long
    Dim r As Long
    Dim g As Long
    Dim b As Long
    Dim oMainSeq As Sequence


    r = InputBox("Please enter Red number in: RGB(red,green,blue)", "Change Top Shape Color", "068")
    g = InputBox("Please enter Green number in: RGB(red,green,blue)", "Change Top Shape Color", "114")
    b = InputBox("Please enter Blue number in: RGB(red,green,blue)", "Change Top Shape Color", "196")


    Set oMainSeq = ActivePresentation.Slides(1).TimeLine.MainSequence
    
    For j = 1 To oMainSeq.Count
        With oMainSeq(j)
            If .EffectType = msoAnimEffectChangeFillColor Then
                If .Shape.Type = msoAutoShape Then
                    If .Shape.AutoShapeType = msoShapeHeptagon Then
                        .Behaviors(3).SetEffect.Property = msoAnimShapeFillColor
                        .Behaviors(3).SetEffect.To = RGB(r, g, b)
                    End If
                        
                End If
                
            End If
        End With
    Next j


    MsgBox "Done"


End Sub

See if I'm understanding better with this one

[dibyendu2280]

Thanks Sir @Paul_Hossler
Now it is perfectly working as i wanted. In this universe there are few people having knowledge of PowerPoint vba you are one of them. Thanks again sir to save me lot of time.
Sir one last request to you , How can i replace heptagonal shape to another shape like hexagon, octagon which is keep in other PowerPoint presentation & import to this slide without affecting the animation.

[Paul_Hossler]

1. Temporarily insert a sample of the shape that you want to change to

2. Select it

3. Run test2()

4. All AutoShapes on all slides will be changed to that (#1 above) shape (you can change to just Slide(1) )

5. The temp shape will be deleted


The original names and original sizes of the shapes don't change, so they're still called "Heptagon1" and the new shape fits into the old shape's box

Sub test2()
    Dim oPres As Presentation
    Dim oSlide As Slide
    Dim oShape As Shape, oNewShape As Shape
    
    
    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
    
    Set oPres = ActivePresentation
    
    For Each oSlide In oPres.Slides
        For Each oShape In oSlide.Shapes
            If oShape.Type = msoAutoShape Then oShape.AutoShapeType = oNewShape.AutoShapeType
        Next
    Next


    oNewShape.Delete
    


End Sub

[dibyendu2280]

Thanks Sir @Paul_Hossler
Working great. Sir i am asking too much question to you & you are giving all solution to my problem. now I implemented above code in my project & it changes all shapes(including all rectangle shape) to hexagon shape. So how to select particular shape(in my case heptagon) to change to hexagon shape.(do not want to change other shape like rectangle shape to hexagon shape).

[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

[dibyendu2280]

Thanks Sir @Paul_Hossler
Working perfectly. I have no words to appreciate you. May god bless you.

[Paul_Hossler]

There are more elegant (and less confusing) ways to do it using a UserForm and some lists

Let me know if youwant/need to upgrade the macros

[dibyendu2280]

There are more elegant (and less confusing) ways to do it using a UserForm and some lists

Let me know if youwant/need to upgrade the macros

Thanks Sir @Paul_Hossler
Yes I need the upgrade micros.
Sir want to implement above micros in my other project where hexagon shape is inside a group & wanted to change it to heptagon shape(there are other shape also ie rectangular shape) but gets error message "Selected Shape must be an AutoShape"
I uploaded the presentation. please look if possible. Thanks again.

[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

[dibyendu2280]

Thanks Sir @Paul_Hossler
Working like a charm. You are the most helpful person in this forum. May god bless you.

[dibyendu2280]

Thanks Sir @Paul_Hossler
Shape is exactly change to my desire custom shape which i inserted in presentation but not the size(ie length, width, height). As a example, I want to change hexagon shape to heptagon shape so I inserted a heptagonal shape & run micros it changes all hexagonal shape to heptagonal shape . It changes only shape but not the exact size of heptagon which I inserted. Is it possible to change the size of hexagonal to the size of heptagonal shape. Sir please look into if some modification in above micros doe the job.

[Paul_Hossler]

Sure

[dibyendu2280]

Thanks Sir @Paul_Hossler,
Working nice. Now I customize my shape size. I have no words to appreciates you. May god bless you. Sir I implement above micro in my project & shape size changes as I wanted but not replacing shape center to center(ie not align center/concentric both shape) & final shape not align to center of the previous shape. Please see the presentation. I try adding .Top & .Left in below code but no luck. Please advice sir

Private Sub pvtChangeAutoShapeType(o As Shape)
    With o
        If .Type <> msoAutoShape Then Exit Sub
        If .AutoShapeType <> tShapeToChange Then Exit Sub
.AutoShapeType = tShapeAfterChange
.Height = oShapeAfterChange.Height
        .Width = oShapeAfterChange.Width
.Top = oShapeAfterChange.Width.Top
        .Left = oShapeAfterChange.Left
End With
End Sub