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?
Guess we're SOL then? lol
Hmmm, if I step through this with F8 it works perfect. Thoughts
Sub TransOutlineOff()Dim s As Shape, p As Integer, srOutlines As ShapeRange, ob As Integer ob = 0 For p = 1 To ActiveDocument.Pages.Count ActiveDocument.Pages(p).Activate Set srOutlines = FindAllShapes.Shapes.FindShapes(Query:="@com.transparency.type > 0") For Each s In srOutlines.Shapes s.Transparency.AppliedTo = cdrApplyToFill Next s ob = ob + srOutlines.Count srOutlines.RemoveAll Next p' MsgBox "Delete " & ob & " transparency"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 = srAllFor Each s In srAlls.AddToSelectionNext sActiveSelection.Transparency.AppliedTo = cdrApplyToFill
End Function
Uh....wait a minute, the code I pasted up there removes the transparencies altogether. grrr.
Thought I was onto something.
the final version (I think so :) )removes the transparency of the outline (including the PowerClip content) on all pages of the document3835.DelTransOut.zip
Sorry, got a new computer and I've been busy trying to rebuild my custom workspace. grrrr!
Tried the new and it shuts corel down. Same step
oops ... sorry
I made a mistake - I uploaded the wrong (old) fileI'll correct it today
now correct
DelTransOut2.zip
Perfect! Thanks.