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
exactly this was that issue sir any solution for this?
The next code (an adaptation of Shelby code plus my sequence of transforming powerclip Cuves in PowerClip Rectangle) does whatever the initial code used to do plus conversion you need it:
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 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
Sub group_on_selected_rectangles_And_Curve_Repair() Dim srSelection As ShapeRange, srRectangles As ShapeRange Dim sRect As Shape, sShapes As ShapeRange, pCl As PowerClip Dim sRect1 As Shape, pClSh As ShapeRange 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 On Error Resume Next Set pCl = sRect.PowerClip On Error GoTo 0 If Not pCl Is Nothing Then If pCl.Parent.Type = cdrCurveShape Then Set pClSh = pCl.Shapes.All pCl.ExtractShapes Set sRect1 = ActiveLayer.CreateRectangleRect(pCl.Parent.BoundingBox) sRect1.Outline.Color = pCl.Parent.Outline.Color pCl.Parent.Delete pClSh.AddToPowerClip sRect1 ActivePage.SelectShapesFromRectangle sRect1.LeftX, sRect1.BottomY, sRect1.RightX, sRect1.TopY, False ActiveSelectionRange.Group Else ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False ActiveSelectionRange.Group End If Else ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False ActiveSelectionRange.Group End If Next sRect ExitSub: ActiveDocument.ClearSelection Optimization = False EventsEnabled = True ActiveDocument.EndCommandGroup Refresh Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub
You will obtain groups but all powerClip inside them will be rectangles and you can play with their dimensions.
But Eskimo asked about the reason of this dimensions modification and you didn't say anything. At least I did nos see such an answer... So, why?
Besides his logic question I also have two other:
1. Doesn't you bother the rectangle outline color? Can you cut exactly on the edge?
2. Don't you need the bottom yellow rectangle to be outside the powerclip, in order to cut in color?
no i use a macro to none outline at the endi think you are talking something like the below pic
if yes then no doubt i need them i use brian copymaster for that i copy background and increase the background and paste on all the pages i need and put on the backside of the design on all pages. then i print.
I'm afraid you lost me...
So, you firstly add that (let's say) yellow bottom rectangle to the PowerClip, you group all shapes in the PowerClip area and after that you take it out and resize according to each card need?
sorry my english is lowi am giving you a link please have a look it has almost every step i am using to do printing on 468 business cards within minutes with few macro codes.https://we.tl/aw9WD5aTsr
It is a little too complicated for me using so many steps but if you do your job is OK with me, too...
Do you still need something else?
nop just thank you everyone..