Code:
Option Explicit
Sub replaceColorsGDG()
Dim col As New Color, col2 As New Color
Dim orig As Shape, smith As Shape
Dim s As Shape, sp As Shape
Dim pwc As PowerClip
Dim x As Double, y As Double
Dim Shift As Long
Dim a As Boolean, b As Boolean
MsgBox "Select shape with the color you need replace", , "GDG"
a = False
While Not a
a = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorEyeDrop)
If Not a Then
Set orig = ActivePage.SelectShapesAtPoint(x, y, False)
col.CopyAssign orig.Fill.UniformColor
ActiveDocument.ClearSelection
GoTo 1001
End If
Wend
1001:
MsgBox "Select shape with the color you need applied", , "GDG"
b = False
While Not b
b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorEyeDrop)
If Not b Then
Set smith = ActivePage.SelectShapesAtPoint(x, y, False)
col2.CopyAssign smith.Fill.UniformColor
ActiveDocument.ClearSelection
GoTo 1002
End If
Wend
1002:
For Each s In ActivePage.FindShapes
If s.Fill.Type = cdrUniformFill Or Not s.PowerClip Is Nothing Then
Set pwc = Nothing
On Error Resume Next
Set pwc = s.PowerClip
On Error GoTo 0
If Not pwc Is Nothing Then
For Each sp In pwc.Shapes
'sp.CreateSelection
If sp.Fill.Type = cdrUniformFill Then
If sp.Fill.UniformColor.IsSame(col) Then '
sp.Fill.ApplyUniformFill col2
End If
End If
Next sp
Else
If s.Fill.UniformColor.IsSame(col) Then '
s.Fill.ApplyUniformFill col2
End If
End If
End If
Next s
End Sub
MyAccount
