Sub RemoveAllOverPrints()Dim s As ShapeDim p As PageDim srOutlines As ShapeRange, srFills As ShapeRange
For Each p In ActiveDocument.Pagesp.Activate
Set srOutlines = p.Shapes.FindShapes(Query:="@com.OverPrintOutline = 'True'")Set srFills = p.Shapes.FindShapes(Query:="@com.OverPrintFill = 'True'")
For Each s In srOutlines.Shapess.OverprintOutline = FalseNext s
For Each s In srFills.Shapess.OverprintFill = FalseNext sNext pEnd Sub
Myron,
Use my FindAllShapes Function
Sub RemoveAllOverPrints() Dim s As Shape Dim p As Page Dim srOutlines As ShapeRange, srFills As ShapeRange For Each p In ActiveDocument.Pages p.Activate Set srOutlines = FindAllShapes.Shapes.FindShapes(Query:="@com.OverPrintOutline = 'True'") Set srFills = FindAllShapes.Shapes.FindShapes(Query:="@com.OverPrintFill = 'True'") For Each s In srOutlines.Shapes s.OverprintOutline = False Next s For Each s In srFills.Shapes s.OverprintFill = False Next s Next p End Sub Function FindAllShapes() As ShapeRange Dim s As Shape Dim srPowerClipped As New ShapeRange Dim sr As ShapeRange, srAll As New ShapeRange If ActiveSelection.Shapes.Count > 0 Then Set sr = ActiveSelection.Shapes.FindShapes() Else Set sr = ActivePage.Shapes.FindShapes() End If Do For Each s In sr.Shapes.FindShapes(Query:="!@com.powerclip.IsNull") srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes() Next s srAll.AddRange sr sr.RemoveAll sr.AddRange srPowerClipped srPowerClipped.RemoveAll Loop Until sr.Count = 0 Set FindAllShapes = srAll End Function
-Shelby
Thanks