Query a document for any contours

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

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