This works... But not sure if its proper though.. ActiveDocument.BeginCommandGroup "Match Fills" Optimization = True Dim s As Shape Dim sr As ShapeRange Dim ff As FountainFill Dim i As Long Dim j As Long Set pal = ActivePalette Set s = ActiveShape Set sr = ActiveSelectionRange ActiveSelection.Ungroup For Each s In sr.Shapes Select Case s.Fill.Type Case 1 On Error Resume Next i = pal.MatchColor(s.Fill.UniformColor) s.Fill.ApplyUniformFill pal.Color(i) Case 2 Set ff = s.Fill.Fountain For j = 0 To ff.Colors.Count + 1 i = pal.MatchColor(ff.Colors(j).Color) ff.Colors(j).Color = pal.Colors(i) Next j End Select width = 0.003 If s.Type <> cdrGroupShape Then If s.Outline.width > 0 Then j = pal.MatchColor(s.Outline.Color) s.Outline.SetProperties Color:=pal.Color(j) End If End If Next s Call reSampleColors Optimization = False ActiveWindow.Refresh Application.Refresh ActiveDocument.EndCommandGroup
↧