Thread: Document Colors
View Single Post
Old 01-06-2018, 04:03
shark shark is offline
Senior Member
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146

try this:

Sub RemoveWasteColors()
Dim c As Color, sr As New ShapeRange, srAllShapes As ShapeRange, s As Shape
    Set srAllShapes = ActivePage.Shapes.All
    For Each c In ActiveDocument.Palette.Colors
        For Each s In srAllShapes
            If s.Fill.Type = cdrUniformFill Then
                If c.IsSame(s.Fill.UniformColor) Then sr.Add s
            End If
        Next s
        If sr.Count > 0 Then
            srAllShapes.RemoveRange sr: sr.RemoveAll
            With ActiveDocument.Palette
                .RemoveColor .GetIndexOfColor(c)
            End With
        End If
    Next c
End Sub
Reply With Quote