I created a macro to separate contours from selected shapes but there might be others in the doc that are missed.
I'd like to query the document for any shapes with contours and MsgBox "Document still has more Contours"
If you are not worried about Powerclips you can keep this pretty simple like this:
Sub FindMostContours() Dim p As Page Dim srContours As ShapeRange For Each p In ActiveDocument.Pages Set srContours = p.Shapes.FindShapes(Query:="@type='contour'") If srContours.Shapes.Count > 0 Then MsgBox "Document still has more Contours" Exit Sub End If Next p End Sub
If you do need to worry about Powerclips, you just need an additional funtion to dig into them.
Sub FindAllContours() Dim p As Page Dim srContours As ShapeRange For Each p In ActiveDocument.Pages Set srContours = FindAllShapes(p).Shapes.FindShapes(Query:="@type='contour'") If srContours.Shapes.Count > 0 Then MsgBox "Document still has more Contours" Exit Sub End If Next p End Sub Function FindAllShapes(p As Page) As ShapeRange Dim s As Shape Dim sr As ShapeRange Dim srAll As New ShapeRange, srPowerClipped As New ShapeRange Set sr = p.Shapes.FindShapes() 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
Happy Coding,,
-Shelby
Thanks, I was getting closer with my hacking but...
Problem arose when running the SelectSame macro. It would error out hard and lock up corel if the doc had contours. Once I separated all the contours it works fine