Hi, all!
So the ShapeRange.Sort function is really powerful, saving tons of code. You can compare position...
ActiveSelectionRange.Sort "@shape1.left < @shape2.left"
even area in a way...
ActiveSelectionRange.Sort "@shape1.width*@shape1.height > @shape2.width*@shape2.height"
which is great, but my question is - can you stack these? I'd like to sort my ShapeRange in such a way that we have bottom-left shapes first, then the next leftmost one, etc. Basically a Bottom Left sort. I did try some things, like separate sorts, combining the queries with &, but no luck.
Can any of the pros chime in if this is possible? Thanks!
Below is my hacky first attempt at making a top left to bottom right sorter. It's rough but does the job. It's designed to create and order that reads correctly for signage and letter sets.
The sequence test sub is just to illustrate the final order and has no real application. Moreover this doesn't contain my break function so you'll have to break up the shapes yourself before running this.
It's actually a really interesting problem and I had a few more ideas of solving it but ultimately the first method (of sort by height, group by position and size then sort groups by left to right) works well enough.
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 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297
Option Explicit Private LetterSR As ShapeRange 'All letters Private LetterCount As Integer 'Overall Number of Letters Private Larray() As Variant Private LetsLeft As Boolean Private Ai As Integer, Bi As Integer Private AX As Double, AY As Double, AH As Double, AW As Double 'Letter A sizes Private BX As Double, BY As Double, BH As Double, BW As Double 'Letter B sizes Private GX As Double, GY As Double, GH As Double, GW As Double 'Sizes for group box Private AvHeight As Double, Padding As Double Private GrBoxSR As ShapeRange, FinalSR As ShapeRange Private GS As Shape Private GroupCount As Integer 'Number of groups Sub Ordertest() 'Test for ordering the above groups ActiveDocument.Unit = cdrMillimeter ActiveDocument.ReferencePoint = cdrBottomLeft Dim I As Integer Dim TempSR As ShapeRange Set TempSR = ActiveSelectionRange '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - TopSort TempSR '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Set LetterSR = TempSR LetterCount = LetterSR.Shapes.Count For I = 1 To LetterCount AvHeight = AvHeight + LetterSR(I).SizeHeight Next AvHeight = AvHeight / LetterCount Padding = AvHeight * 0.15 ReDim Larray(LetterCount - 1, 1) 'Group letter blongs to For I = 0 To LetterCount - 1 Larray(I, 0) = 0 Larray(I, 1) = "V" Next I Ai = 1 Bi = 1 GroupCount = 1 LetsLeft = True Do While LetsLeft = True '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - GroupTest '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - NextAi '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - GroupCount = GroupCount + 1 Loop GrBoxSR.Delete '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - SequenceTest '- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Set GrBoxSR = Nothing Set FinalSR = Nothing Set GS = Nothing Set TempSR = Nothing Set LetterSR = Nothing Erase Larray ActiveWindow.Refresh Application.Refresh End Sub Private Function NextAi() LetsLeft = False Dim Nc As Integer For Nc = 0 To LetterCount - 1 If Larray(Nc, 0) = 0 Then Ai = Nc + 1 LetsLeft = True Exit For End If Next Nc End Function Private Function LeftSort(ByRef SRToSort As ShapeRange) 'secondary sort by left centre positions SRToSort.Sort "@shape1.left < @shape2.Left" 'SRToSort.Sort "@shape1.left + (@shape1.width/2) - (@shape1.top*0.75) < @shape2.Left+(@shape2.width/2) - (@shape2.top*0.75) " End Function Private Function TopSort(ByRef SRToSort As ShapeRange) 'Initial sort and find First (heightest) Object SRToSort.Sort "@shape1.top > @shape2.top" End Function 'Test Letter A against B to see if they should be grouped Private Function GroupTest() Dim N As NODE Dim Nc As Integer Dim BLS As Shape, ALS As Shape Dim TempSR2 As New ShapeRange Dim GroupedSR As ShapeRange 'Assign Letters to this shaperange for removing from ungrouped range Dim InsideB As Boolean, HorizSet As Integer Set ALS = LetterSR(Ai) ALS.GetBoundingBox AX, AY, AW, AH, False TempSR2.Add ALS HorizSet = 1 For Nc = 0 To LetterCount - 1 Bi = Nc + 1 Set BLS = LetterSR(Bi) If Bi = Ai Then GoTo LetterGrouped 'Don't check letter against itself BLS.GetBoundingBox BX, BY, BW, BH, False 'Primary Test for horizontally aligned letters If HorizSet = 2 Or HorizSet = 1 Then If Not BY + BH > AY + (AH * 1.5) And Not BY < AY - (AH * 0.5) Then 'Y position check If Not BH > AH * 1.5 Then 'HEIGHT check If Not BH < AH * 0.5 Then 'HEIGHT check TempSR2.Add BLS Larray(Nc, 0) = GroupCount HorizSet = 2 Larray(Bi - 1, 1) = "H" Larray(Ai - 1, 1) = "H" End If End If End If End If 'Secondary test to find Vertically aligned letters If HorizSet = 3 Or HorizSet = 1 Then 'Horiztonal sets should not be overrided by Vertical matches If Larray(Bi - 1, 1) = "V" And Larray(Ai - 1, 1) = "V" Then If Not BY < AY - (AH * 2) Then 'Yposition check If Not BY + BH > AY + (AH * 3) Then 'Yposition check 2 If BX + BW < AX + (AW * 1.5) Then 'x range check If BX > AX - (AW * 1) Then If Not BW > AW * 1.25 Then 'Width check If Not BW < AW * 0.75 Then 'width check TempSR2.Add BLS Larray(Nc, 0) = GroupCount HorizSet = 3 BLS.GetBoundingBox AX, AY, AW, AH, False End If End If End If End If End If End If End If End If LetterGrouped: Next Nc 'Test if a shape fits within the group; this is to capture small details like the dots on top of a "i" Set GroupedSR = TempSR2 GroupedSR.GetBoundingBox GX, GY, GW, GH, False Set GS = ActiveLayer.CreateRectangle(GX - (Padding * 0.25), GY + GH + (Padding * 0.5), GX + GW + (Padding * 0.25), GY - (Padding * 0.25)) For Nc = 0 To LetterCount - 1 Bi = Nc + 1 Set BLS = LetterSR(Bi) 'If Larray(Nc, 0) > 0 Then GoTo LetterGrouped2 If Larray(Nc, 0) > Ai Then GoTo LetterGrouped2 InsideB = True For Each N In BLS.DisplayCurve.nodes If Not GS.DisplayCurve.IsPointInside(N.PositionX, N.PositionY) = True Then InsideB = False End If Next N If InsideB = True Then TempSR2.Add BLS Larray(Nc, 0) = GroupCount End If LetterGrouped2: Next Nc If HorizSet = 2 Or HorizSet = 1 Then LeftSort GroupedSR Else TopSort GroupedSR End If GS.CreateSelection If Not GrBoxSR Is Nothing Then GrBoxSR.AddToSelection Set GrBoxSR = ActiveSelectionRange If Not FinalSR Is Nothing Then FinalSR.RemoveRange GroupedSR FinalSR.AddRange GroupedSR Else Set FinalSR = GroupedSR End If Set N = Nothing Set BLS = Nothing Set ALS = Nothing Set TempSR2 = Nothing Set GroupedSR = Nothing End Function 'Link up Letters with lines to show the order of ShapeRange Private Function SequenceTest() Dim C As Long, M As Long, Step As Long 'Lines to change colour from start to finish C = 100: M = 0: Step = 100 / LetterCount Dim I As Integer, AL As Integer, NL As Integer Dim ALet As Shape 'ActiveLetter Dim NLet As Shape 'NextLetter Dim AXC As Double, AYC As Double Dim NXC As Double, NYC As Double Dim NumberS As Shape, NumberSR As New ShapeRange Dim DotS As Shape, DotSR As New ShapeRange Dim LineS As Shape, LineSR As New ShapeRange For I = 1 To LetterCount - 1 AL = I: NL = AL + 1 Set ALet = FinalSR(AL) ALet.GetPositionEx cdrCenter, AXC, AYC ALet.Outline.Color.CMYKAssign C, M, 0, 0 Set NLet = FinalSR(NL) NLet.GetPositionEx cdrCenter, NXC, NYC Set LineS = ActiveLayer.CreateLineSegment(AXC, AYC, NXC, NYC) LineS.Outline.Color.CMYKAssign C, M, 0, 0 LineSR.Add LineS Set DotS = ActiveLayer.CreateEllipse2(AXC, AYC, 50, 50) DotS.Outline.SetNoOutline DotS.Fill.UniformColor.CMYKAssign C, M, 0, 0 DotSR.Add DotS Set NumberS = ActiveLayer.CreateArtisticText(AXC, AYC, AL, , , , 200, cdrTrue, cdrFalse, cdrNoFontLine, cdrCenterAlignment) NumberS.ConvertToCurves NumberS.Fill.UniformColor.CMYKAssign 0, 0, 0, 0 NumberS.SetPositionEx cdrCenter, AXC, AYC NumberSR.Add NumberS C = C - Step: If C < 0 Then C = 0 M = M + Step: If M > 100 Then M = 100 If NL = LetterCount Then 'Add dot and number for last entry NLet.Outline.Color.CMYKAssign 0, 100, 0, 0 Set DotS = ActiveLayer.CreateEllipse2(NXC, NYC, 50, 50) DotS.Outline.SetNoOutline DotS.Fill.UniformColor.CMYKAssign 0, 100, 0, 0 DotSR.Add DotS Set NumberS = ActiveLayer.CreateArtisticText(NXC, NYC, LetterCount, , , , 200, cdrTrue, cdrFalse, cdrNoFontLine, cdrCenterAlignment) NumberS.ConvertToCurves NumberS.Fill.UniformColor.CMYKAssign 0, 0, 0, 0 NumberS.SetPositionEx cdrCenter, NXC, NYC NumberSR.Add NumberS End If Next I Set LineS = LineSR.Group Set DotS = DotSR.Group Set NumberS = NumberSR.Group DotSR.Add LineS DotSR.Add DotS DotSR.Add NumberS Set LineS = DotSR.Group LineS.OrderToFront Set ALet = Nothing Set NLet = Nothing Set LineS = Nothing Set LineSR = Nothing Set NumberS = Nothing Set NumberSR = Nothing Set DotS = Nothing Set DotSR = Nothing End Function
Hello,
FWIW, we have ecut 6 as a commercial solution for this. It offers various sorting parameters in its routing module. It's ready to go, for those who want to cut jobs faster and with less movement on the machine.