How to get entire list of fill and fountain colors, pantones, rgb, cmyk etc and replace according to my need in fill, fountain, outline every where on the page even it is powerclip too.
Alex wrote a color replace macro called Oberon Color Replacer, wOxxOm then improved on it. And I made some changes so that it would work on both 32-bit and 64-bit systems.
You can download the gms from here: OberonPlace.com Forums - View Single Post - Color Replacer advanced remake
-Shelby
but this is not working for fountain fill.
Its working for fountain fills for me.
Here is before the replace:
And here is after:
Yeah right but actually it is not working when the object is in powerclip.
I guess you could try my old two-click solution that seems to work (quite possible someone will find something less than efficient in there, but it works). Just click the color to replace and then the new color. If it does not work when reading a color from inside a powerclip then that could be due to different color settings. Just clone that one object to outside, run the macro, click it and the rest will be processed properly.
Option Explicit Sub ColorReplace() If ActiveDocument Is Nothing Then GoTo EndIt Dim Sh As Shape Dim Col As Color Dim Dol As Color Dim X As Double Dim Y As Double Dim EmptyClick As Boolean EmptyClick = ActiveDocument.GetUserClick(X, Y, 0, 10, False, cdrCursorEyeDrop) If EmptyClick Then GoTo EndIt Set Col = ActiveDocument.SampleColorAtPoint(X, Y) EmptyClick = ActiveDocument.GetUserClick(X, Y, 0, 10, False, cdrCursorEyeDrop) If EmptyClick Then GoTo EndIt Set Dol = ActiveDocument.SampleColorAtPoint(X, Y) boostStart "ColorReplace" For Each Sh In ActivePage.FindShapes(, , True) If Sh.Type <> cdrBlendGroupShape And Sh.Type <> cdrCustomEffectGroupShape And Sh.Type <> 10 Then SwapColors Sh, Col, Dol End If Next Sh boostFinish TRUE EndIt: End Sub Sub SwapColors(Sh As Shape, Col As Color, Dol As Color) Dim Ts As Shape Dim Current As Integer If Sh.Type = cdrGroupShape Then If Sh.Shapes.Count > 1 Then For Each Ts In Sh.Shapes SwapColors Ts, Col, Dol Next Ts End If End If If Sh.Type <> cdrBlendGroupShape And Sh.Type <> cdrCustomEffectGroupShape Then If Sh.Fill.Type = cdrUniformFill Then If Sh.Fill.UniformColor.GetColorDistanceFrom(Col) < 2 And Sh.Fill.UniformColor.Type = Col.Type Then Sh.Fill.ApplyUniformFill Dol End If If Sh.Fill.Type = cdrFountainFill Then If Sh.Fill.Fountain.StartColor.GetColorDistanceFrom(Col) < 2 And Sh.Fill.Fountain.StartColor.Type = Col.Type Then Sh.Fill.Fountain.StartColor.CopyAssign Dol End If For Current = 0 To Sh.Fill.Fountain.Colors.Count - 1 If Sh.Fill.Fountain.Colors(Current).Color.GetColorDistanceFrom(Col) < 2 And Sh.Fill.Fountain.Colors(Current).Color.Type = Col.Type Then Sh.Fill.Fountain.Colors(Current).Color.CopyAssign Dol End If Next Current If Sh.Fill.Fountain.EndColor.GetColorDistanceFrom(Col) < 2 And Sh.Fill.Fountain.EndColor.Type = Col.Type Then Sh.Fill.Fountain.EndColor.CopyAssign Dol End If End If If Not Sh.Outline Is Nothing And Sh.Type <> cdrDropShadowGroupShape Then If Sh.Outline.Type <> cdrNoOutline Then If Sh.Outline.Color.GetColorDistanceFrom(Col) < 2 And Sh.Outline.Color.Type = Col.Type Then Sh.Outline.Color.CopyAssign Dol End If End If End If Dim PWC As PowerClip Set PWC = Sh.PowerClip If Not PWC Is Nothing Then For Each Ts In Sh.PowerClip.Shapes SwapColors Ts, Col, Dol Next Ts End If End Sub Sub boostStart(Optional unDo$) On Error Resume Next If Len(unDo) Then ActiveDocument.BeginCommandGroup unDo CorelScriptTools.BeginWaitCursor Optimization = TRUE EventsEnabled = FALSE ActiveDocument.SaveSettings ActiveDocument.PreserveSelection = FALSE End Sub Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False) On Error Resume Next ActiveDocument.PreserveSelection = TRUE ActiveDocument.RestoreSettings EventsEnabled = TRUE Optimization = FALSE If endUndoGroup Then ActiveDocument.EndCommandGroup ActiveWindow.Refresh Application.Refresh End Sub
A little more information. What version of CD are you using? At what point does this message pop up?