Search in Powerclip

Dim pwc As PowerClip, OM As ShapeRange, AM As Shape, s As Shape, g As Shape
ActiveDocument.BeginCommandGroup
'Optimization = True
ActivePage.Shapes.FindShapes(Query:="!@com.powerclip.IsNull").CreateSelection 
End
For Each s In ActiveSelection.Shapes
Set OM = s.PowerClip.ExtractShapes
OM.UngroupAll
For Each g In ActiveSelection.Shapes
Set AM = g.ConvertToBitmapEx(cdrCMYKColorImage, False, True, 200, cdrNormalAntiAliasing, True, False, 95)
AM.AddToPowerClip s, cdrFalse
Next
Next
'Optimization = False
ActiveDocument.EndCommandGroup
ActiveDocument.ClearSelection
ActiveWindow.Refresh
End Sub

This work almost fine, but i need to ungroup all objects

Is there has a way to save group structure?

Dim SR As ShapeRange, SM As ShapeRange, GN As New ShapeRange, s As Shape, g As Shape, b As Shape
ActiveDocument.BeginCommandGroup

For Each s In ActivePage.Shapes.FindShapes(Type:=cdrGroupShape)
Set SM = s.UngroupEx
SM.UngroupAll

For Each g In ActiveSelection.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
Set SR = g.PowerClip.ExtractShapes
SR.UngroupAll
For Each b In ActiveSelection.Shapes
If Not b.Transparency.Type = cdrNoTransparency Then
Set AM = b.ConvertToBitmapEx(cdrCMYKColorImage, False, True, 200, cdrNormalAntiAliasing, True, False, 95)
Else
Set AM = b
End If
GN.Add AM
Next
GN.AddToPowerClip g, cdrFalse

Next

SM.Group
Next

ActiveDocument.EndCommandGroup
End Sub

I just don't know what to do next, it work only with one group, next group produce error.

if i use only "Set SM = s.UngroupEx" then it works fine BUT only when group not contain other groups. If i use "Set SM = s.UngroupEx" with "SM.UngroupAll" then script get error after first group. And i cant; make something like "Set SM = s.UngroupAll" cause this make error to :(

i found that "ActivePage.Shapes.FindShapes(Type:=cdrGroupShape)" get all groups, even groups in groups, so when i do ungroupall, all subsequence get broken. How to find only main groups?

i found a solution :)

this is probably cumbersome and there is a more elegant solution, but i make all i can.

Dim SR As ShapeRange, SM As ShapeRange, GN As New ShapeRange, s As Shape, g As Shape, b As Shape, PG As New ShapeRange
On Error GoTo ErDn
ActiveDocument.BeginCommandGroup

ActiveLayer.Shapes.All.CreateSelection
For Each s In ActiveSelection.Shapes
If Not s.Type = cdrGroupShape Then
s.RemoveFromSelection
End If
Next
Set PG = ActiveSelectionRange
lngObjCount = ActiveSelection.Shapes.Count
For i = 1 To lngObjCount
PG(i).CreateSelection
ActiveSelection.UngroupAll
Set SM = ActiveSelectionRange
For Each g In ActiveSelection.Shapes.FindShapes(Query:="!@com.powerclip.IsNull")
Set SR = g.PowerClip.ExtractShapes
SR.UngroupAll
For Each b In ActiveSelection.Shapes
If Not b.Transparency.Type = cdrNoTransparency Then
Set AM = b.ConvertToBitmapEx(cdrCMYKColorImage, False, True, 200, cdrNormalAntiAliasing, True, False, 95)
Else
Set AM = b
End If
GN.Add AM
Next
GN.AddToPowerClip g, cdrFalse
Next
SM.Group
Next

ErDn:
ActiveDocument.EndCommandGroup
End Sub