Change Fill color using VBA in PowerPoint

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:

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

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

Code:

---

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

---

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

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

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

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

Quote:

---

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

---

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

Attachment 28452

Code:

---

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

---

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.

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

Code:

---

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

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.

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

Code:

---

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

---

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).

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

Code:

---

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

---

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

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

Quote:

---

Originally Posted by 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

---

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.

Some changes to Step2

Slide 2 has a Group

Code:

---

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

---

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

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.

Sure

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

Code:

---

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

---

You need to work out the math a little better

Is this what you wanted?

Code:

---

Private Sub pvtChangeAutoShapeType(o As Shape)
    Dim CenterTop As Double, CenterLeft As Double   
    With o
        If .Type <> msoAutoShape Then Exit Sub
        If .AutoShapeType <> tShapeToChange Then Exit Sub
        .AutoShapeType = tShapeAfterChange       
        CenterTop = .Top + .Height / 2#
        CenterLeft = .Left + .Width / 2#     
        .Height = oShapeAfterChange.Height
        .Width = oShapeAfterChange.Width                       
        .Left = CenterLeft - oShapeAfterChange.Width / 2#
        .Top = CenterTop - oShapeAfterChange.Height / 2#
    End With
End Sub

---

Thanks sir,

Yes. This is what I exactly wanted.

Thanks Sir @Paul_Hossler

The above micro works on the basis of shape type ie rectangle/diamond/hexagon/heptagon.
Now in below presentation there are two different size rectangular shape(one black-10 qty & other orange-10 qty).
So when I want to change orange color rectangle(small) only & run the code it changes all rectangular shapes(black-big one also).


So is it possible to some modification in micros so that the above problem solve or can I replace the shape by shape id ie RectangleBottom1, RectangleBottom2, RectangleBottom3
ie Shapes("RectangleBottom" & j) &
j = 1 to 10
next j


So that, finally I can change small size rectangle shape only without disturbing other rectangle shape(black-big).

Original color remains

That can be changed

Thanks Sir @Paul_Hossler,
Now perfectly working. You are a genius moreover most helpful person for me. May god bless you.

Try ver 10

I allows the shape to be replaced to be selected within a grouped shape

There was some code in about changing the destination color that I wasn't sure about so it's commented out

Thanks Sir,

Its perfectly working.
I used Pickup & Apply for copy color & shape property of inserted shape to apply destination shape.
In above code you select the shape to be changed by similar color & shape but is it possible to add another criteria shape id(shape name ie rectangle) as per example there are eight shapes rectangle1, rectangle2, rectangle3, rectangle4,rectangleOuter1, rectangleOuter2, rectangleOuter3, rectangleOuter4 all are same size & same color.
Now I want to change only rectangle1, rectangle2, rectangle3, rectangle4 shapes. Above code change all shapes.

Sorry, the way it's written it changes all shapes of the designated type

Wonderful code.
Sir I insert a custom shape (ie by merging circle & rectangle shape) but not replacing the octagons.

I read the solution(post: Change Fill color using VBA in PowerPoint) you had given in the post. I have one question to you. I insert a freeform shape to replace other shape but not its not replace with freeform shape. It will be huge help if you edit the code to get such result. It working with autoshape only. I want to insert my customize shape. Thanking you.

I think Freeform shapes might be tricky, but try this version

Sir, Slide1 is missing from file.

Made changes to try and test

I copied Slide 1

Sir, I tried to replace Heptagon shape with freeform 7 shape but it not replaced the heptagon shape.

Sorry, the macros work by changing the AutoShapeType, and there's no easy way to change an auto shape to a non-autoshape without copy/pasting

Maybe some one will have an idea

Sir @Paul_Hossler, hope you are doing well. Sir I need some help to implement some feature to this beautiful code. This Code replace shape keeping their center points constant. But I want to add some offset to the shape to be replaced. for better understanding I upload example file. Any solution will be highly appreciable.