Query a document for any contours

 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"

Parents
  • 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

Reply Children
No Data