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 (http://www.vbaexpress.com/forum/attachment.php?attachmentid=28451&d=1620832981)

[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

28452



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

[Paul_Hossler]

You need to work out the math a little better

Is this what you wanted?





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

[dibyendu2280]

Thanks sir,

Yes. This is what I exactly wanted.

[dibyendu2280]

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

[Paul_Hossler]

Original color remains

That can be changed

[dibyendu2280]

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

[Paul_Hossler]

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

[dibyendu2280]

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.

[Paul_Hossler]

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

[Jhon90]

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

[papuapu]

I read the solution(post: Change Fill color using VBA in PowerPoint (http://www.vbaexpress.com/forum/showthread.php?68760-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.

[Paul_Hossler]

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

[papuapu]

Sir, Slide1 is missing from file.

[Paul_Hossler]

Made changes to try and test

I copied Slide 1

[papuapu]

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

[Paul_Hossler]

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

[papuapu]

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.