any easy fast possible way to group all these business cards separately. https://we.tl/tylZcTY3p6
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
Sub group_on_selected_rectangles() Dim srRectangles As ShapeRange Dim sRect As Shape On Error GoTo ErrHandler ActiveDocument.BeginCommandGroup "Group objects on selected rectangles" EventsEnabled = False Optimization = True Set srRectangles = ActiveSelectionRange For Each sRect In srRectangles ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False ActiveSelectionRange.Group Next sRect ExitSub: Optimization = False EventsEnabled = True ActiveDocument.EndCommandGroup Refresh Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub
Eskimo,
I hope you do not mind, I have changed your code a little bit. I added some CQL to find all other shapes the same size as the original one selected.
Happy Coding,
-Shelby
Sub group_on_selected_rectangles() Dim srSelection As ShapeRange, srRectangles As ShapeRange Dim sRect As Shape Set srSelection = ActiveSelectionRange If srSelection.Shapes.Count > 1 Then MsgBox "Please only select one shape.": Exit Sub On Error GoTo ErrHandler ActiveDocument.BeginCommandGroup "Group objects on selected rectangles" EventsEnabled = False Optimization = True Set srRectangles = ActivePage.Shapes.FindShapes(Query:="@width = {" & srSelection(1).SizeWidth & " in } and @height ={" & srSelection(1).SizeHeight & " in }") For Each sRect In srRectangles ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False ActiveSelectionRange.Group Next sRect ExitSub: ActiveDocument.ClearSelection Optimization = False EventsEnabled = True ActiveDocument.EndCommandGroup Refresh Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub
How to"change size of business card of entire last row "? All the logic of the above presented code selects and groups only the shapes INSIDE THE SAME DIMENSIONS SHAPE as the initially selected one.
Besides that I can not understand what really happens... Can you post a link to that specific file behaving in that way? Maybe after testing it I will understand what do you mean and maybe why that behavior.
https://we.tl/tylZcTY3p6
I tested the file and everything runs smooth... Corel X8 64 bit.
Al the shapes in the wished rectangle area are well grouped. Any not grouped shape remained. I cannot reproduce your problem. Are you sure that you sent that file? You mentioned something about "if i change size of business card of entire last row". What did you mean? The shapes in the last row have the same dimensions like the rest of them...
Looking to your sample picture shell I understand that the last some shapes disappear and instead of them you have that long triangle?
Some of the PowerClip frames are Curves, not Rectangles.
If I select one of those and try to resize it, it does something like this:
VIDEO:crazy curve.
Ouch! I was thinking that the problem appears after running the macro...
It is very strange indeed.
What I have in mind now would be to identify that strange powerClip shape and do some tricks in order to replace it with a real rectangle: check if powerClip Parent is a curveShape, put in variables the position and dimensions of the actual powerClip Curve, put in a variable the shape range inside powerclip, extract shapes from powerclip, delete powerclip parent, create a rectangle having the same dimensions in the same position and add extracted shapes to the new rectangle. It should not be so complicated I think...
I will come back with a piece of code doing that. I hope in some minutes...
I did something much like that yesterday evening...
Sub make_powerclips_rectangles() Dim sr As ShapeRange Dim s1 As Shape Dim s2 As Shape Dim srExtracted As ShapeRange Set sr = ActivePage.Shapes.FindShapes(Query:="!@com.powerclip.IsNull") For Each s1 In sr Set s2 = ActiveLayer.CreateRectangleRect(s1.BoundingBox) s2.Outline.Color = s1.Outline.Color s2.Outline.Width = s1.Outline.Width Set srExtracted = s1.PowerClip.ExtractShapes s1.Delete srExtracted.AddToPowerClip s2 Next s1 End Sub
I will add here that it's not clear to me exactly why or how the sizes of business cards are to be changed.
If the PowerClip frames are resized asymmetrically, then the content will be distorted.
The "ultimate end result" remains undefined...
But on that page there are some other shapes not being powerclip... The ones necessary to be grouped.
On the contrary I think we should look for powerclip shapes, identify the parent type and act only on powerclip curve shapes ones.
I replaced all of the PowerClip frames with new PowerClip frames. I did not do anything to other content.
One reason I wrote it that way - replace them all - is because I was considering the option of being able to replace them all with larger rectangles.
This is what I did now for such a strange powerClip Curve selection:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
Sub PowerClipCurveRepair() Dim pCl As PowerClip, pClSh As ShapeRange, sRect As Shape On Error Resume Next Set pCl = ActiveShape.PowerClip On Error GoTo 0 If Not pCl Is Nothing Then If pCl.Parent.Type = cdrCurveShape Then ActiveDocument.BeginCommandGroup "Make PowerClip Rectangle" Set pClSh = pCl.Shapes.All pCl.ExtractShapes Set sRect = ActiveLayer.CreateRectangleRect(pCl.Parent.BoundingBox) sRect.Outline.Color = pCl.Parent.Outline.Color pCl.Parent.Delete pClSh.AddToPowerClip sRect ActiveDocument.EndCommandGroup End If End If End Sub
It can be easily adapted inside the code posted by Shelby.