continuation of the topicMyron sayOh, forgot to mention there is more than 1 powerclip. Imagine a "boat load" of powerclips that have a boat load of shapes in them and they all have overprint fills. We want to remove the overprint from all those shapes within each powerclip.
p.s. back to this original post. Just like the overprint fills issue above. Set each transparent shape within multiple powerclips to Fill Only"
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
this fragment will be executed until all the power clips have been processed
Still not working. Errors at Set srOutlines = FindAllShapes.Shapes.FindShapes(Query:="@com.OverPrintOutline = 'True'")
Sub RemoveOverprintFromPowerClip() 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 = 0End Function
can I see your document - where does the error appear?
overprint macro testing.zip
Hmm-Hmm, the code you posted above - yes - gives an error. The original Shelby code does not give an error. Here is my gmsDelOVER.zip
So, I copied all of Shelby's code and replaced my entire code. Works fine now.
Now what about
Sub RemoveOutlineTransparencies() 'not good for powerclipped shapesDim s As Shape, FindPCShapes As ShapeRangeFor Each s In ActivePage.Shapes.FindShapes(Query:="@com.transparency.type > 0")s.Transparency.AppliedTo = cdrApplyToFillNext s
End SubFunction 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 = srAllEnd Function
let's stick our finger up our nose and think a little...
firstly, let's remove this from DIM - FindPCShapes As ShapeRange - this is a function and it is described below last time we were looking for overprint with this function, and now transparency
and you are looking not for function but..For Each s In ActivePage.Shapes.FindShapes(Query:="@com.transparency.type > 0")...correct and check
yes
Sub RemoveOutlineTransparencies() 'not good for powerclipped shapes Dim s As Shape Dim p As Page Dim sr As ShapeRangeFor Each p In ActiveDocument.Pages p.Activate Set sr = p.Shapes.FindShapes(Query:="@com.transparency.type > 0") For Each s In sr.Shapes s.Transparency.AppliedTo = cdrApplyToFill Next s Next pEnd Sub
And not this either. grrrrr
Sub RemoveOutlineTransparencies() 'not good for powerclipped shapes Dim s As Shape Dim p As Page Dim sr As ShapeRange For Each p In ActiveDocument.Pages p.Activate Set sr = p.Shapes.FindShapes(Query:="@com.transparency.type > 0") For Each s In sr.Shapes.FindShapes(Query:="@com.transparency.type > 0") 'For Each s In sr.Shapes s.Transparency.AppliedTo = cdrApplyToFill Next s Next pEnd 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 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 = srAllEnd Function
Oh no ... just try this5282.DelTransOut.zip
I don't understand what this macro is for, someone please explain to me
this is a little off topic - a special case - the main question was here