CQL does not find shapes in PowerClip

[aakkaarr]

hi
I found out that CQL does not find shapes in PowerClip
How to add shapes in PowerClip to say shaperange of textshape type

[runflacruiser]

HI.
Well hopefully there actually is a way to do it entirely with CQL.
But here's something you can use for now...maybe.

Sub addPCShapesToSR()

    Dim s As Shape, s1 As Shape, sr As ShapeRange, sr2 As New ShapeRange
    Dim pc As PowerClip
    
    Set sr = ActivePage.Shapes.FindShapes
    For Each s In sr
        Set pc = s.PowerClip
        If Not pc Is Nothing Then
            For Each s1 In pc.Shapes
                pc.EnterEditMode
                sr2.Add s1
                pc.LeaveEditMode
            Next s1
        End If
    Next s
    sr2.CreateSelection
End Sub

~John

[shelbym]

Here is a Function that I wrote that will do this. (And for fun I used CQL to find the powerclips) If nothing is selected it searches the page, if you do have a selection only the selection is searched.

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 = srAll
End Function

You then can use the Function and CQL and you should get the results you wanted.

Sub Testing()
    FindAllShapes.Shapes.FindShapes(Query:="@fill.color = 'green'").ApplyUniformFill CreateRGBColor(255, 255, 0)
End Sub

Hope that helps,

-Shelby

[runflacruiser]

Hi.
I love it Shelby. I like how you dig into the Powerclips.
Here's a little modification of it that allows you to specify a level of Powerclipped shapes.

Set lngLevel to:
-1 to get all Powerclipped shapes only regardless of how many levels deep they go..
0 or leave blank to get all shapes, as you have it.
1 Plus to get shapes based on what level deep they are powerclipped. Example: Set to 2 to get shapes that are 2 levels deep Powerclipped.

~John

Sub Testing2()
    FindAllPCShapes(2).Shapes.FindShapes.ApplyUniformFill CreateRGBColor(255, 255, 0)
End Sub

Function FindAllPCShapes(Optional LngLevel As Long) As ShapeRange ' Shelby's function
    Dim s As Shape
    Dim srPowerClipped As New ShapeRange, srJustClipped As New ShapeRange
    Dim sr As ShapeRange, srAll As New ShapeRange
    Dim bFound As Boolean, i&
    
    bFound = False
    If ActiveSelection.Shapes.count > 0 Then
        Set sr = ActiveSelection.Shapes.FindShapes()
    Else
        Set sr = ActivePage.Shapes.FindShapes()
    End If
    i = 0
    Do
        For Each s In sr.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
            srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
        Next s
        If srPowerClipped.count > 0 Then bFound = True: i = i + 1
        If i = LngLevel And bFound Then Set FindAllPCShapes = srPowerClipped: Exit Function
        bFound = False
        srAll.AddRange sr
        sr.RemoveAll
        sr.AddRange srPowerClipped
        If LngLevel = -1 Then srJustClipped.AddRange srPowerClipped
        srPowerClipped.RemoveAll
    Loop Until sr.count = 0
    
    If LngLevel = -1 Then
        Set FindAllPCShapes = srJustClipped
    Else
        Set FindAllPCShapes = srAll
    End If
End Function