Spaces:
No application file
No application file
| Option Explicit | |
| ' ============================================================ | |
| ' CORELDRAW BANNER AUTO NESTING V3 | |
| ' | |
| ' MODEL A - REAL OBJECT NESTING | |
| ' | |
| ' OPTIMIZATION: | |
| ' 1. All objects must be placed | |
| ' 2. Right waste target <= 10 cm | |
| ' 3. Left edge alignment | |
| ' 4. Top edge alignment | |
| ' 5. Minimum material | |
| ' | |
| ' MULTI START: | |
| ' 6 sorting strategies | |
| ' x | |
| ' 4 MaxRects fitness strategies (BSSF, BAF, BLSF, Contact Point) | |
| ' | |
| ' V3 CHANGES FROM V2: | |
| ' - Alignment penalty is now blended directly into the | |
| ' placement score (not just an EPS tie-break). | |
| ' - New "Contact Point" fitness strategy (fitMode = 4): | |
| ' maximizes touching edge length with the roll wall | |
| ' and already-placed objects. | |
| ' - Small height bias added to placement scoring, nudging | |
| ' the packer toward a shorter overall bounding box. | |
| ' - Free rectangle list is merged (adjacent free rects | |
| ' combined) in addition to being pruned, reducing | |
| ' fragmentation of the search space. | |
| ' - Post-processing local search (RebalanceRolls): tries to | |
| ' drain the last roll into earlier rolls to cut roll count | |
| ' and material further after the multi-start search. | |
| ' - Removed dead/overwritten assignment in | |
| ' ApplyNestingToObjects. | |
| ' | |
| ' NO: | |
| ' - dummy rectangles | |
| ' - labels | |
| ' - layout shapes | |
| ' | |
| ' YES: | |
| ' - real CorelDRAW objects | |
| ' - 90 degree rotation | |
| ' - multiple roll widths | |
| ' ============================================================ | |
| ' ============================================================ | |
| ' CONSTANTS | |
| ' ============================================================ | |
| Private Const EPS As Double = 0.000001 | |
| Private Const ROLL_GAP As Double = 5# | |
| Private Const MAX_ROLLS As Long = 100 | |
| ' Target maximum unused width at right side. | |
| Private Const MAX_RIGHT_WASTE As Double = 10# | |
| ' Objects whose edges differ by <= this value | |
| ' are considered aligned. | |
| Private Const ALIGN_TOLERANCE As Double = 0.5 | |
| ' Weight applied to the alignment penalty when it is blended | |
| ' directly into the per-placement score. Alignment penalty is | |
| ' measured in cm, same scale as BSSF/BLSF leftover distances, | |
| ' so this acts as a meaningful nudge for those modes. For BAF | |
| ' (area-based, cm^2) the alignment contribution is relatively | |
| ' smaller by nature of the scale difference -- this is | |
| ' intentional: BAF still optimizes area first, alignment only | |
| ' breaks near-ties. | |
| Private Const W_ALIGN As Double = 2# | |
| ' Small weight biasing placement toward a lower resulting top | |
| ' edge (y + h), which nudges the packer to keep the overall | |
| ' bounding box shorter. Kept small so it only matters when | |
| ' fitness/alignment are close. | |
| Private Const W_HEIGHT As Double = 0.001 | |
| ' ============================================================ | |
| ' DATA TYPES | |
| ' ============================================================ | |
| Private Type TBanner | |
| Label As String | |
| OrigW As Double | |
| OrigH As Double | |
| margin As Double | |
| End Type | |
| Private Type TFreeRect | |
| x As Double | |
| y As Double | |
| w As Double | |
| h As Double | |
| End Type | |
| Private Type TPlaced | |
| rid As Long | |
| x As Double | |
| y As Double | |
| w As Double | |
| h As Double | |
| Rotated As Boolean | |
| End Type | |
| Private Type TRoll | |
| placed() As TPlaced | |
| placedCount As Long | |
| UsedHeight As Double | |
| End Type | |
| ' ============================================================ | |
| ' BASIC MATH | |
| ' ============================================================ | |
| Private Function MinD(ByVal a As Double, ByVal b As Double) As Double | |
| If a < b Then | |
| MinD = a | |
| Else | |
| MinD = b | |
| End If | |
| End Function | |
| Private Function MaxD(ByVal a As Double, ByVal b As Double) As Double | |
| If a > b Then | |
| MaxD = a | |
| Else | |
| MaxD = b | |
| End If | |
| End Function | |
| Private Function AbsD(ByVal a As Double) As Double | |
| If a < 0# Then | |
| AbsD = -a | |
| Else | |
| AbsD = a | |
| End If | |
| End Function | |
| Private Function AreaOf(ByRef item As TBanner) As Double | |
| AreaOf = _ | |
| (item.OrigW + 2# * item.margin) * _ | |
| (item.OrigH + 2# * item.margin) | |
| End Function | |
| ' ============================================================ | |
| ' SORT VALUE | |
| ' | |
| ' 1 = Area descending | |
| ' 2 = Width descending | |
| ' 3 = Height descending | |
| ' 4 = Short side descending | |
| ' 5 = Long side descending | |
| ' 6 = Aspect ratio descending | |
| ' ============================================================ | |
| Private Function SortValue(ByRef item As TBanner, ByVal sortMode As Long) As Double | |
| Dim w As Double | |
| Dim h As Double | |
| Dim shortSide As Double | |
| Dim longSide As Double | |
| w = item.OrigW + 2# * item.margin | |
| h = item.OrigH + 2# * item.margin | |
| shortSide = MinD(w, h) | |
| longSide = MaxD(w, h) | |
| Select Case sortMode | |
| Case 1 | |
| SortValue = w * h | |
| Case 2 | |
| SortValue = w | |
| Case 3 | |
| SortValue = h | |
| Case 4 | |
| SortValue = shortSide | |
| Case 5 | |
| SortValue = longSide | |
| Case 6 | |
| If shortSide > EPS Then | |
| SortValue = longSide / shortSide | |
| Else | |
| SortValue = 0# | |
| End If | |
| Case Else | |
| SortValue = w * h | |
| End Select | |
| End Function | |
| ' ============================================================ | |
| ' SORT INDEX | |
| ' ============================================================ | |
| Private Sub SortIndex(ByRef items() As TBanner, ByRef sourceIdx() As Long, ByVal n As Long, ByVal sortMode As Long, ByRef sortedIdx() As Long) | |
| Dim i As Long | |
| Dim j As Long | |
| Dim tmp As Long | |
| ReDim sortedIdx(1 To n) | |
| For i = 1 To n | |
| sortedIdx(i) = sourceIdx(i) | |
| Next i | |
| For i = 1 To n - 1 | |
| For j = i + 1 To n | |
| If SortValue(items(sortedIdx(j)), sortMode) > SortValue(items(sortedIdx(i)), sortMode) Then | |
| tmp = sortedIdx(i) | |
| sortedIdx(i) = sortedIdx(j) | |
| sortedIdx(j) = tmp | |
| End If | |
| Next j | |
| Next i | |
| End Sub | |
| ' ============================================================ | |
| ' RECTANGLE INTERSECTION | |
| ' ============================================================ | |
| Private Function RectsIntersect(ByRef a As TFreeRect, ByRef b As TFreeRect) As Boolean | |
| If a.x >= b.x + b.w - EPS Then | |
| RectsIntersect = False | |
| Exit Function | |
| End If | |
| If b.x >= a.x + a.w - EPS Then | |
| RectsIntersect = False | |
| Exit Function | |
| End If | |
| If a.y >= b.y + b.h - EPS Then | |
| RectsIntersect = False | |
| Exit Function | |
| End If | |
| If b.y >= a.y + a.h - EPS Then | |
| RectsIntersect = False | |
| Exit Function | |
| End If | |
| RectsIntersect = True | |
| End Function | |
| ' ============================================================ | |
| ' RECTANGLE CONTAINMENT | |
| ' ============================================================ | |
| Private Function IsContained(ByRef a As TFreeRect, ByRef b As TFreeRect) As Boolean | |
| If a.x + EPS < b.x Then | |
| IsContained = False | |
| Exit Function | |
| End If | |
| If a.y + EPS < b.y Then | |
| IsContained = False | |
| Exit Function | |
| End If | |
| If a.x + a.w > b.x + b.w + EPS Then | |
| IsContained = False | |
| Exit Function | |
| End If | |
| If a.y + a.h > b.y + b.h + EPS Then | |
| IsContained = False | |
| Exit Function | |
| End If | |
| IsContained = True | |
| End Function | |
| ' ============================================================ | |
| ' PRUNE FREE RECTANGLES | |
| ' ============================================================ | |
| Private Sub PruneFree(ByRef freeRects() As TFreeRect, ByRef freeCount As Long) | |
| Dim i As Long | |
| Dim j As Long | |
| Dim k As Long | |
| Dim contained As Boolean | |
| If freeCount <= 1 Then Exit Sub | |
| i = 1 | |
| Do While i <= freeCount | |
| contained = False | |
| For j = 1 To freeCount | |
| If i <> j Then | |
| If IsContained(freeRects(i), freeRects(j)) Then | |
| contained = True | |
| Exit For | |
| End If | |
| End If | |
| Next j | |
| If contained Then | |
| For k = i To freeCount - 1 | |
| freeRects(k) = freeRects(k + 1) | |
| Next k | |
| freeCount = freeCount - 1 | |
| Else | |
| i = i + 1 | |
| End If | |
| Loop | |
| If freeCount <= 0 Then | |
| ReDim freeRects(1 To 1) | |
| Else | |
| ReDim Preserve freeRects(1 To freeCount) | |
| End If | |
| End Sub | |
| ' ============================================================ | |
| ' MERGE ADJACENT FREE RECTANGLES | |
| ' | |
| ' Combines free rectangles that share a full edge (same | |
| ' opposite dimension and touching side) into one larger | |
| ' rectangle. Reduces fragmentation left behind by PruneFree, | |
| ' giving later placements more/larger candidate free rects | |
| ' to choose from. | |
| ' ============================================================ | |
| Private Sub MergeFreeRects(ByRef freeRects() As TFreeRect, ByRef freeCount As Long) | |
| Dim i As Long | |
| Dim j As Long | |
| Dim k As Long | |
| Dim merged As Boolean | |
| Dim a As TFreeRect | |
| Dim b As TFreeRect | |
| If freeCount <= 1 Then Exit Sub | |
| Do | |
| merged = False | |
| i = 1 | |
| Do While i <= freeCount And Not merged | |
| j = i + 1 | |
| Do While j <= freeCount And Not merged | |
| a = freeRects(i) | |
| b = freeRects(j) | |
| ' Horizontal merge: same y and h, touching left/right edge | |
| If AbsD(a.y - b.y) <= EPS And AbsD(a.h - b.h) <= EPS Then | |
| If AbsD((a.x + a.w) - b.x) <= EPS Then | |
| freeRects(i).w = a.w + b.w | |
| For k = j To freeCount - 1 | |
| freeRects(k) = freeRects(k + 1) | |
| Next k | |
| freeCount = freeCount - 1 | |
| merged = True | |
| ElseIf AbsD((b.x + b.w) - a.x) <= EPS Then | |
| freeRects(i).x = b.x | |
| freeRects(i).w = a.w + b.w | |
| For k = j To freeCount - 1 | |
| freeRects(k) = freeRects(k + 1) | |
| Next k | |
| freeCount = freeCount - 1 | |
| merged = True | |
| End If | |
| End If | |
| ' Vertical merge: same x and w, touching top/bottom edge | |
| If Not merged Then | |
| If AbsD(a.x - b.x) <= EPS And AbsD(a.w - b.w) <= EPS Then | |
| If AbsD((a.y + a.h) - b.y) <= EPS Then | |
| freeRects(i).h = a.h + b.h | |
| For k = j To freeCount - 1 | |
| freeRects(k) = freeRects(k + 1) | |
| Next k | |
| freeCount = freeCount - 1 | |
| merged = True | |
| ElseIf AbsD((b.y + b.h) - a.y) <= EPS Then | |
| freeRects(i).y = b.y | |
| freeRects(i).h = a.h + b.h | |
| For k = j To freeCount - 1 | |
| freeRects(k) = freeRects(k + 1) | |
| Next k | |
| freeCount = freeCount - 1 | |
| merged = True | |
| End If | |
| End If | |
| End If | |
| j = j + 1 | |
| Loop | |
| i = i + 1 | |
| Loop | |
| Loop While merged | |
| If freeCount <= 0 Then | |
| ReDim freeRects(1 To 1) | |
| Else | |
| ReDim Preserve freeRects(1 To freeCount) | |
| End If | |
| End Sub | |
| ' ============================================================ | |
| ' ADD VALID FREE RECTANGLE | |
| ' ============================================================ | |
| Private Sub AddIfValid(ByRef arr() As TFreeRect, ByRef count As Long, ByVal x As Double, ByVal y As Double, ByVal w As Double, ByVal h As Double) | |
| If w <= EPS Then Exit Sub | |
| If h <= EPS Then Exit Sub | |
| count = count + 1 | |
| arr(count).x = x | |
| arr(count).y = y | |
| arr(count).w = w | |
| arr(count).h = h | |
| End Sub | |
| ' ============================================================ | |
| ' SPLIT FREE RECTANGLES | |
| ' ============================================================ | |
| Private Sub PlaceAndSplit(ByRef freeRects() As TFreeRect, ByRef freeCount As Long, ByVal placedX As Double, ByVal placedY As Double, ByVal placedW As Double, ByVal placedH As Double) | |
| Dim oldCount As Long | |
| Dim newCount As Long | |
| Dim maxNew As Long | |
| Dim i As Long | |
| Dim fr As TFreeRect | |
| Dim placed As TFreeRect | |
| Dim tmp() As TFreeRect | |
| oldCount = freeCount | |
| If oldCount <= 0 Then Exit Sub | |
| maxNew = oldCount * 4 + 10 | |
| ReDim tmp(1 To maxNew) | |
| placed.x = placedX | |
| placed.y = placedY | |
| placed.w = placedW | |
| placed.h = placedH | |
| For i = 1 To oldCount | |
| fr = freeRects(i) | |
| If Not RectsIntersect(fr, placed) Then | |
| AddIfValid tmp, newCount, fr.x, fr.y, fr.w, fr.h | |
| Else | |
| ' LEFT | |
| AddIfValid tmp, newCount, _ | |
| fr.x, _ | |
| fr.y, _ | |
| placed.x - fr.x, _ | |
| fr.h | |
| ' RIGHT | |
| AddIfValid tmp, newCount, _ | |
| placed.x + placed.w, _ | |
| fr.y, _ | |
| (fr.x + fr.w) - (placed.x + placed.w), _ | |
| fr.h | |
| ' BOTTOM | |
| AddIfValid tmp, newCount, _ | |
| fr.x, _ | |
| fr.y, _ | |
| fr.w, _ | |
| placed.y - fr.y | |
| ' TOP | |
| AddIfValid tmp, newCount, _ | |
| fr.x, _ | |
| placed.y + placed.h, _ | |
| fr.w, _ | |
| (fr.y + fr.h) - (placed.y + placed.h) | |
| End If | |
| Next i | |
| If newCount <= 0 Then | |
| ReDim freeRects(1 To 1) | |
| freeCount = 0 | |
| Exit Sub | |
| End If | |
| ReDim freeRects(1 To newCount) | |
| For i = 1 To newCount | |
| freeRects(i) = tmp(i) | |
| Next i | |
| freeCount = newCount | |
| PruneFree freeRects, freeCount | |
| MergeFreeRects freeRects, freeCount | |
| End Sub | |
| ' ============================================================ | |
| ' CONTACT LENGTH (for Contact Point fitness) | |
| ' | |
| ' Total length of edges of the candidate rectangle that | |
| ' touch the roll's left/bottom wall or an already-placed | |
| ' rectangle. Higher = tighter fit against neighbors. | |
| ' ============================================================ | |
| Private Function ContactLength(ByVal candX As Double, ByVal candY As Double, ByVal rw As Double, ByVal rh As Double, ByRef placed() As TPlaced, ByVal placedCount As Long) As Double | |
| Dim i As Long | |
| Dim total As Double | |
| Dim overlapLen As Double | |
| Dim px As Double | |
| Dim py As Double | |
| Dim pw As Double | |
| Dim ph As Double | |
| total = 0# | |
| ' Contact with roll's left wall | |
| If AbsD(candX - 0#) <= EPS Then | |
| total = total + rh | |
| End If | |
| ' Contact with roll's bottom edge | |
| If AbsD(candY - 0#) <= EPS Then | |
| total = total + rw | |
| End If | |
| For i = 1 To placedCount | |
| px = placed(i).x | |
| py = placed(i).y | |
| pw = placed(i).w | |
| ph = placed(i).h | |
| ' Shared vertical edge (left-right touching) | |
| If AbsD(candX - (px + pw)) <= EPS Or AbsD((candX + rw) - px) <= EPS Then | |
| overlapLen = MinD(candY + rh, py + ph) - MaxD(candY, py) | |
| If overlapLen > 0# Then | |
| total = total + overlapLen | |
| End If | |
| End If | |
| ' Shared horizontal edge (bottom-top touching) | |
| If AbsD(candY - (py + ph)) <= EPS Or AbsD((candY + rh) - py) <= EPS Then | |
| overlapLen = MinD(candX + rw, px + pw) - MaxD(candX, px) | |
| If overlapLen > 0# Then | |
| total = total + overlapLen | |
| End If | |
| End If | |
| Next i | |
| ContactLength = total | |
| End Function | |
| ' ============================================================ | |
| ' PLACEMENT SCORE | |
| ' | |
| ' 1 = BSSF | |
| ' 2 = BAF | |
| ' 3 = BLSF | |
| ' 4 = Contact Point (maximize touching perimeter) | |
| ' | |
| ' Lower returned value = better, consistently across modes | |
| ' (mode 4 returns a negated contact length so that more | |
| ' contact still means "lower/better"). | |
| ' ============================================================ | |
| Private Function PlacementScore(ByRef fr As TFreeRect, ByVal rw As Double, ByVal rh As Double, ByVal fitMode As Long, ByVal candX As Double, ByVal candY As Double, ByRef placed() As TPlaced, ByVal placedCount As Long) As Double | |
| Dim leftoverW As Double | |
| Dim leftoverH As Double | |
| Dim areaWaste As Double | |
| Dim contact As Double | |
| Select Case fitMode | |
| Case 1 | |
| leftoverW = fr.w - rw | |
| leftoverH = fr.h - rh | |
| PlacementScore = MinD(leftoverW, leftoverH) | |
| Case 2 | |
| areaWaste = (fr.w * fr.h) - (rw * rh) | |
| PlacementScore = areaWaste | |
| Case 3 | |
| leftoverW = fr.w - rw | |
| leftoverH = fr.h - rh | |
| PlacementScore = MaxD(leftoverW, leftoverH) | |
| Case 4 | |
| contact = ContactLength(candX, candY, rw, rh, placed, placedCount) | |
| PlacementScore = -contact | |
| Case Else | |
| leftoverW = fr.w - rw | |
| leftoverH = fr.h - rh | |
| PlacementScore = MinD(leftoverW, leftoverH) | |
| End Select | |
| End Function | |
| ' ============================================================ | |
| ' FIND MINIMUM ALIGNMENT DISTANCE | |
| ' | |
| ' Checks candidate left edge against existing left edges. | |
| ' | |
| ' Checks candidate top edge against existing top edges. | |
| ' ============================================================ | |
| Private Function AlignmentPenalty(ByRef placed() As TPlaced, ByVal placedCount As Long, ByVal x As Double, ByVal y As Double, ByVal w As Double, ByVal h As Double) As Double | |
| Dim i As Long | |
| Dim leftDist As Double | |
| Dim topDist As Double | |
| Dim candidateTop As Double | |
| Dim existingTop As Double | |
| Dim bestLeft As Double | |
| Dim bestTop As Double | |
| Dim alignedLeft As Boolean | |
| Dim alignedTop As Boolean | |
| If placedCount <= 0 Then | |
| AlignmentPenalty = 0# | |
| Exit Function | |
| End If | |
| bestLeft = 1E+30 | |
| bestTop = 1E+30 | |
| candidateTop = y + h | |
| For i = 1 To placedCount | |
| leftDist = AbsD(x - placed(i).x) | |
| existingTop = placed(i).y + placed(i).h | |
| topDist = AbsD(candidateTop - existingTop) | |
| If leftDist < bestLeft Then | |
| bestLeft = leftDist | |
| End If | |
| If topDist < bestTop Then | |
| bestTop = topDist | |
| End If | |
| Next i | |
| alignedLeft = (bestLeft <= ALIGN_TOLERANCE) | |
| alignedTop = (bestTop <= ALIGN_TOLERANCE) | |
| If alignedLeft Then | |
| bestLeft = 0# | |
| End If | |
| If alignedTop Then | |
| bestTop = 0# | |
| End If | |
| ' The smaller the value, the better. | |
| ' | |
| ' Strong preference for straight cut lines. | |
| AlignmentPenalty = bestLeft + bestTop | |
| End Function | |
| ' ============================================================ | |
| ' CHECK WHETHER POSITION IS BETTER | |
| ' | |
| ' V3: alignment is already folded into "score" by the caller, | |
| ' so this only needs score, then y, then x as tie-breakers. | |
| ' ============================================================ | |
| Private Function IsBetterPlacement(ByVal score As Double, ByVal tieY As Double, ByVal tieX As Double, ByVal bestScore As Double, ByVal bestY As Double, ByVal bestX As Double) As Boolean | |
| If score < bestScore - EPS Then | |
| IsBetterPlacement = True | |
| Exit Function | |
| End If | |
| If AbsD(score - bestScore) <= EPS Then | |
| If tieY < bestY - EPS Then | |
| IsBetterPlacement = True | |
| Exit Function | |
| End If | |
| If AbsD(tieY - bestY) <= EPS Then | |
| If tieX < bestX - EPS Then | |
| IsBetterPlacement = True | |
| Exit Function | |
| End If | |
| End If | |
| End If | |
| IsBetterPlacement = False | |
| End Function | |
| ' ============================================================ | |
| ' FIND BEST PLACEMENT | |
| ' | |
| ' V3: combines base fitness score, alignment penalty (W_ALIGN) | |
| ' and a height bias (W_HEIGHT) into one combined score before | |
| ' comparing candidates, so alignment now genuinely influences | |
| ' which free rectangle gets chosen, not just a rare EPS tie. | |
| ' ============================================================ | |
| Private Function FindBestPlacement(ByRef freeRects() As TFreeRect, ByVal freeCount As Long, ByVal reqW As Double, ByVal reqH As Double, ByVal allowRotation As Boolean, ByVal fitMode As Long, ByRef placed() As TPlaced, ByVal placedCount As Long, ByRef bestX As Double, ByRef bestY As Double, ByRef bestW As Double, ByRef bestH As Double, ByRef bestRot As Boolean) As Boolean | |
| Dim i As Long | |
| Dim rw As Double | |
| Dim rh As Double | |
| Dim baseScore As Double | |
| Dim alignScore As Double | |
| Dim heightBias As Double | |
| Dim combinedScore As Double | |
| Dim bestScore As Double | |
| Dim tieY As Double | |
| Dim tieX As Double | |
| Dim bestTieY As Double | |
| Dim bestTieX As Double | |
| Dim found As Boolean | |
| bestScore = 1E+30 | |
| bestTieY = 1E+30 | |
| bestTieX = 1E+30 | |
| found = False | |
| For i = 1 To freeCount | |
| ' ==================================================== | |
| ' NORMAL | |
| ' ==================================================== | |
| rw = reqW | |
| rh = reqH | |
| If rw <= freeRects(i).w + EPS And rh <= freeRects(i).h + EPS Then | |
| baseScore = PlacementScore(freeRects(i), rw, rh, fitMode, freeRects(i).x, freeRects(i).y, placed, placedCount) | |
| alignScore = AlignmentPenalty(placed, placedCount, freeRects(i).x, freeRects(i).y, rw, rh) | |
| heightBias = freeRects(i).y + rh | |
| combinedScore = baseScore + alignScore * W_ALIGN + heightBias * W_HEIGHT | |
| tieY = freeRects(i).y | |
| tieX = freeRects(i).x | |
| If IsBetterPlacement(combinedScore, tieY, tieX, bestScore, bestTieY, bestTieX) Then | |
| bestScore = combinedScore | |
| bestTieY = tieY | |
| bestTieX = tieX | |
| bestX = freeRects(i).x | |
| bestY = freeRects(i).y | |
| bestW = rw | |
| bestH = rh | |
| bestRot = False | |
| found = True | |
| End If | |
| End If | |
| ' ==================================================== | |
| ' ROTATED | |
| ' ==================================================== | |
| If allowRotation Then | |
| rw = reqH | |
| rh = reqW | |
| If rw <= freeRects(i).w + EPS And rh <= freeRects(i).h + EPS Then | |
| baseScore = PlacementScore(freeRects(i), rw, rh, fitMode, freeRects(i).x, freeRects(i).y, placed, placedCount) | |
| alignScore = AlignmentPenalty(placed, placedCount, freeRects(i).x, freeRects(i).y, rw, rh) | |
| heightBias = freeRects(i).y + rh | |
| combinedScore = baseScore + alignScore * W_ALIGN + heightBias * W_HEIGHT | |
| tieY = freeRects(i).y | |
| tieX = freeRects(i).x | |
| If IsBetterPlacement(combinedScore, tieY, tieX, bestScore, bestTieY, bestTieX) Then | |
| bestScore = combinedScore | |
| bestTieY = tieY | |
| bestTieX = tieX | |
| bestX = freeRects(i).x | |
| bestY = freeRects(i).y | |
| bestW = rw | |
| bestH = rh | |
| bestRot = True | |
| found = True | |
| End If | |
| End If | |
| End If | |
| Next i | |
| FindBestPlacement = found | |
| End Function | |
| ' ============================================================ | |
| ' PACK ONE ROLL | |
| ' ============================================================ | |
| Private Sub PackOneBin(ByRef items() As TBanner, ByRef sourceIdx() As Long, ByVal n As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal sortMode As Long, ByVal fitMode As Long, ByRef placed() As TPlaced, ByRef placedCount As Long, ByRef outIdx() As Long, ByRef outCount As Long) | |
| Dim freeRects() As TFreeRect | |
| Dim sortedIdx() As Long | |
| Dim freeCount As Long | |
| Dim k As Long | |
| Dim rid As Long | |
| Dim reqW As Double | |
| Dim reqH As Double | |
| Dim bestX As Double | |
| Dim bestY As Double | |
| Dim bestW As Double | |
| Dim bestH As Double | |
| Dim bestRot As Boolean | |
| ReDim placed(1 To n) | |
| ReDim outIdx(1 To n) | |
| placedCount = 0 | |
| outCount = 0 | |
| ReDim freeRects(1 To 1) | |
| freeCount = 1 | |
| freeRects(1).x = 0# | |
| freeRects(1).y = 0# | |
| freeRects(1).w = rollWidth | |
| freeRects(1).h = maxHeight | |
| SortIndex items, sourceIdx, n, sortMode, sortedIdx | |
| For k = 1 To n | |
| rid = sortedIdx(k) | |
| reqW = items(rid).OrigW + 2# * items(rid).margin | |
| reqH = items(rid).OrigH + 2# * items(rid).margin | |
| If FindBestPlacement(freeRects, freeCount, reqW, reqH, allowRotation, fitMode, placed, placedCount, bestX, bestY, bestW, bestH, bestRot) Then | |
| placedCount = placedCount + 1 | |
| placed(placedCount).rid = rid | |
| placed(placedCount).x = bestX | |
| placed(placedCount).y = bestY | |
| placed(placedCount).w = bestW | |
| placed(placedCount).h = bestH | |
| placed(placedCount).Rotated = bestRot | |
| PlaceAndSplit freeRects, freeCount, bestX, bestY, bestW, bestH | |
| Else | |
| outCount = outCount + 1 | |
| outIdx(outCount) = rid | |
| End If | |
| Next k | |
| End Sub | |
| ' ============================================================ | |
| ' PACK MULTIPLE ROLLS | |
| ' ============================================================ | |
| Private Sub PackMultiRoll(ByRef items() As TBanner, ByVal n As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal sortMode As Long, ByVal fitMode As Long, ByRef rolls() As TRoll, ByRef rollCount As Long, ByRef notPlaced As Long) | |
| Dim remaining() As Long | |
| Dim nextRemaining() As Long | |
| Dim placed() As TPlaced | |
| Dim outIdx() As Long | |
| Dim remainingCount As Long | |
| Dim outCount As Long | |
| Dim placedCount As Long | |
| Dim i As Long | |
| Dim safety As Long | |
| rollCount = 0 | |
| notPlaced = 0 | |
| If n <= 0 Then Exit Sub | |
| ReDim rolls(1 To MAX_ROLLS) | |
| ReDim remaining(1 To n) | |
| For i = 1 To n | |
| remaining(i) = i | |
| Next i | |
| remainingCount = n | |
| Do While remainingCount > 0 | |
| safety = safety + 1 | |
| If safety > MAX_ROLLS Then | |
| notPlaced = remainingCount | |
| Exit Do | |
| End If | |
| PackOneBin items, remaining, remainingCount, rollWidth, maxHeight, allowRotation, sortMode, fitMode, placed, placedCount, outIdx, outCount | |
| If placedCount <= 0 Then | |
| notPlaced = remainingCount | |
| Exit Do | |
| End If | |
| rollCount = rollCount + 1 | |
| rolls(rollCount).placedCount = placedCount | |
| ReDim rolls(rollCount).placed(1 To placedCount) | |
| For i = 1 To placedCount | |
| rolls(rollCount).placed(i) = placed(i) | |
| Next i | |
| rolls(rollCount).UsedHeight = CalcPlacedHeight(placed, placedCount) | |
| If outCount <= 0 Then | |
| remainingCount = 0 | |
| Exit Do | |
| End If | |
| ReDim nextRemaining(1 To outCount) | |
| For i = 1 To outCount | |
| nextRemaining(i) = outIdx(i) | |
| Next i | |
| ReDim remaining(1 To outCount) | |
| For i = 1 To outCount | |
| remaining(i) = nextRemaining(i) | |
| Next i | |
| remainingCount = outCount | |
| Loop | |
| End Sub | |
| ' ============================================================ | |
| ' BUILD FREE RECTS FROM AN EXISTING PLACED LIST | |
| ' | |
| ' Reconstructs the free-rectangle map for a roll from its | |
| ' current placed items, so the rebalancing local search can | |
| ' test whether an extra item fits into that roll. | |
| ' ============================================================ | |
| Private Sub BuildFreeRects(ByRef placed() As TPlaced, ByVal placedCount As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByRef freeRects() As TFreeRect, ByRef freeCount As Long) | |
| Dim i As Long | |
| ReDim freeRects(1 To 1) | |
| freeCount = 1 | |
| freeRects(1).x = 0# | |
| freeRects(1).y = 0# | |
| freeRects(1).w = rollWidth | |
| freeRects(1).h = maxHeight | |
| For i = 1 To placedCount | |
| PlaceAndSplit freeRects, freeCount, placed(i).x, placed(i).y, placed(i).w, placed(i).h | |
| Next i | |
| End Sub | |
| ' ============================================================ | |
| ' REBALANCE ROLLS (POST-PROCESS LOCAL SEARCH) | |
| ' | |
| ' After the multi-start search picks a winning configuration, | |
| ' try to drain the last roll's items into earlier rolls' | |
| ' remaining free space. If a roll becomes fully empty, it is | |
| ' removed, reducing roll count and material. This is a light | |
| ' local search, not a full optimum, but often reduces waste | |
| ' further versus the pure greedy multi-start result. | |
| ' ============================================================ | |
| Private Sub RebalanceRolls(ByRef items() As TBanner, ByRef rolls() As TRoll, ByRef rollCount As Long, ByVal rollWidth As Double, ByVal maxHeight As Double, ByVal allowRotation As Boolean, ByVal fitMode As Long) | |
| Dim moved As Boolean | |
| Dim found As Boolean | |
| Dim safety As Long | |
| Dim srcRoll As Long | |
| Dim dstRoll As Long | |
| Dim i As Long | |
| Dim k As Long | |
| Dim r As Long | |
| Dim rid As Long | |
| Dim reqW As Double | |
| Dim reqH As Double | |
| Dim freeRects() As TFreeRect | |
| Dim freeCount As Long | |
| Dim bestX As Double | |
| Dim bestY As Double | |
| Dim bestW As Double | |
| Dim bestH As Double | |
| Dim bestRot As Boolean | |
| Dim newPlaced() As TPlaced | |
| Dim newCount As Long | |
| safety = 0 | |
| Do | |
| moved = False | |
| safety = safety + 1 | |
| If safety > 500 Then Exit Do | |
| If rollCount <= 1 Then Exit Do | |
| srcRoll = rollCount | |
| i = 1 | |
| Do While i <= rolls(srcRoll).placedCount | |
| rid = rolls(srcRoll).placed(i).rid | |
| reqW = items(rid).OrigW + 2# * items(rid).margin | |
| reqH = items(rid).OrigH + 2# * items(rid).margin | |
| found = False | |
| For dstRoll = 1 To rollCount - 1 | |
| BuildFreeRects rolls(dstRoll).placed, rolls(dstRoll).placedCount, rollWidth, maxHeight, freeRects, freeCount | |
| If FindBestPlacement(freeRects, freeCount, reqW, reqH, allowRotation, fitMode, rolls(dstRoll).placed, rolls(dstRoll).placedCount, bestX, bestY, bestW, bestH, bestRot) Then | |
| ' --- place into destination roll --- | |
| rolls(dstRoll).placedCount = rolls(dstRoll).placedCount + 1 | |
| ReDim Preserve rolls(dstRoll).placed(1 To rolls(dstRoll).placedCount) | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).rid = rid | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).x = bestX | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).y = bestY | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).w = bestW | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).h = bestH | |
| rolls(dstRoll).placed(rolls(dstRoll).placedCount).Rotated = bestRot | |
| rolls(dstRoll).UsedHeight = CalcPlacedHeight(rolls(dstRoll).placed, rolls(dstRoll).placedCount) | |
| ' --- remove from source roll --- | |
| newCount = 0 | |
| ReDim newPlaced(1 To rolls(srcRoll).placedCount) | |
| For k = 1 To rolls(srcRoll).placedCount | |
| If k <> i Then | |
| newCount = newCount + 1 | |
| newPlaced(newCount) = rolls(srcRoll).placed(k) | |
| End If | |
| Next k | |
| rolls(srcRoll).placedCount = newCount | |
| If newCount > 0 Then | |
| ReDim rolls(srcRoll).placed(1 To newCount) | |
| For k = 1 To newCount | |
| rolls(srcRoll).placed(k) = newPlaced(k) | |
| Next k | |
| rolls(srcRoll).UsedHeight = CalcPlacedHeight(rolls(srcRoll).placed, newCount) | |
| Else | |
| rolls(srcRoll).UsedHeight = 0# | |
| End If | |
| found = True | |
| moved = True | |
| Exit For | |
| End If | |
| Next dstRoll | |
| If Not found Then | |
| i = i + 1 | |
| End If | |
| Loop | |
| If rolls(srcRoll).placedCount = 0 Then | |
| For r = srcRoll To rollCount - 1 | |
| rolls(r) = rolls(r + 1) | |
| Next r | |
| rollCount = rollCount - 1 | |
| End If | |
| Loop While moved | |
| End Sub | |
| ' ============================================================ | |
| ' CALCULATE USED HEIGHT | |
| ' ============================================================ | |
| Private Function CalcPlacedHeight(ByRef placed() As TPlaced, ByVal placedCount As Long) As Double | |
| Dim i As Long | |
| Dim h As Double | |
| h = 0# | |
| For i = 1 To placedCount | |
| h = MaxD(h, placed(i).y + placed(i).h) | |
| Next i | |
| CalcPlacedHeight = h | |
| End Function | |
| ' ============================================================ | |
| ' MATERIAL USED | |
| ' ============================================================ | |
| Private Function CalcMaterialUsed(ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double | |
| Dim r As Long | |
| Dim total As Double | |
| total = 0# | |
| For r = 1 To rollCount | |
| total = total + rollWidth * rolls(r).UsedHeight | |
| Next r | |
| CalcMaterialUsed = total | |
| End Function | |
| ' ============================================================ | |
| ' TRUE DESIGN AREA | |
| ' ============================================================ | |
| Private Function CalcTrueArea(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long) As Double | |
| Dim r As Long | |
| Dim i As Long | |
| Dim rid As Long | |
| Dim total As Double | |
| total = 0# | |
| For r = 1 To rollCount | |
| For i = 1 To rolls(r).placedCount | |
| rid = rolls(r).placed(i).rid | |
| total = total + items(rid).OrigW * items(rid).OrigH | |
| Next i | |
| Next r | |
| CalcTrueArea = total | |
| End Function | |
| ' ============================================================ | |
| ' WASTE | |
| ' ============================================================ | |
| Private Function CalcWaste(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double | |
| Dim material As Double | |
| Dim trueArea As Double | |
| material = CalcMaterialUsed(rolls, rollCount, rollWidth) | |
| trueArea = CalcTrueArea(items, rolls, rollCount) | |
| If material <= EPS Then | |
| CalcWaste = 1# | |
| Else | |
| CalcWaste = (material - trueArea) / material | |
| End If | |
| End Function | |
| ' ============================================================ | |
| ' RIGHT WASTE | |
| ' | |
| ' Maximum unused horizontal width on the right | |
| ' of any roll. | |
| ' ============================================================ | |
| Private Function CalcRightWaste(ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) As Double | |
| Dim r As Long | |
| Dim i As Long | |
| Dim rightEdge As Double | |
| Dim maxRightEdge As Double | |
| Dim waste As Double | |
| Dim worstWaste As Double | |
| worstWaste = 0# | |
| For r = 1 To rollCount | |
| maxRightEdge = 0# | |
| For i = 1 To rolls(r).placedCount | |
| rightEdge = rolls(r).placed(i).x + rolls(r).placed(i).w | |
| maxRightEdge = MaxD(maxRightEdge, rightEdge) | |
| Next i | |
| waste = rollWidth - maxRightEdge | |
| If waste < 0# Then | |
| waste = 0# | |
| End If | |
| worstWaste = MaxD(worstWaste, waste) | |
| Next r | |
| CalcRightWaste = worstWaste | |
| End Function | |
| ' ============================================================ | |
| ' TOTAL ALIGNMENT SCORE | |
| ' | |
| ' Lower = better. | |
| ' | |
| ' Measures: | |
| ' - left edge alignment | |
| ' - top edge alignment | |
| ' | |
| ' A perfectly aligned edge contributes zero. | |
| ' ============================================================ | |
| Private Function CalcAlignmentScore(ByRef rolls() As TRoll, ByVal rollCount As Long) As Double | |
| Dim r As Long | |
| Dim i As Long | |
| Dim j As Long | |
| Dim score As Double | |
| Dim leftDist As Double | |
| Dim topDist As Double | |
| Dim candidateTop As Double | |
| Dim otherTop As Double | |
| Dim bestLeft As Double | |
| Dim bestTop As Double | |
| Dim alignedLeft As Boolean | |
| Dim alignedTop As Boolean | |
| score = 0# | |
| For r = 1 To rollCount | |
| For i = 1 To rolls(r).placedCount | |
| bestLeft = 1E+30 | |
| bestTop = 1E+30 | |
| candidateTop = rolls(r).placed(i).y + rolls(r).placed(i).h | |
| For j = 1 To rolls(r).placedCount | |
| If i <> j Then | |
| leftDist = AbsD(rolls(r).placed(i).x - rolls(r).placed(j).x) | |
| otherTop = rolls(r).placed(j).y + rolls(r).placed(j).h | |
| topDist = AbsD(candidateTop - otherTop) | |
| bestLeft = MinD(bestLeft, leftDist) | |
| bestTop = MinD(bestTop, topDist) | |
| End If | |
| Next j | |
| alignedLeft = (bestLeft <= ALIGN_TOLERANCE) | |
| alignedTop = (bestTop <= ALIGN_TOLERANCE) | |
| If alignedLeft Then | |
| bestLeft = 0# | |
| End If | |
| If alignedTop Then | |
| bestTop = 0# | |
| End If | |
| If bestLeft < 1E+20 Then | |
| score = score + bestLeft | |
| End If | |
| If bestTop < 1E+20 Then | |
| score = score + bestTop | |
| End If | |
| Next i | |
| Next r | |
| CalcAlignmentScore = score | |
| End Function | |
| ' ============================================================ | |
| ' PACK SCORE | |
| ' | |
| ' HARD PRIORITY: | |
| ' | |
| ' 1. Not placed | |
| ' 2. Right waste > 10 cm | |
| ' | |
| ' SOFT PRIORITY: | |
| ' | |
| ' 3. Material | |
| ' 4. Alignment | |
| ' 5. Roll count | |
| ' | |
| ' Important: | |
| ' A solution with right waste <= 10 cm | |
| ' is always preferred over a solution | |
| ' with right waste > 10 cm. | |
| ' ============================================================ | |
| Private Function PackScore(ByRef items() As TBanner, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal notPlaced As Long, ByVal rollWidth As Double, ByRef rightWaste As Double, ByRef alignmentScore As Double, ByRef materialUsed As Double) As Double | |
| Dim excessRight As Double | |
| Dim alignmentNormalized As Double | |
| rightWaste = CalcRightWaste(rolls, rollCount, rollWidth) | |
| alignmentScore = CalcAlignmentScore(rolls, rollCount) | |
| materialUsed = CalcMaterialUsed(rolls, rollCount, rollWidth) | |
| ' -------------------------------------------------------- | |
| ' HARD FAILURE: | |
| ' not all objects placed | |
| ' -------------------------------------------------------- | |
| If notPlaced > 0 Then | |
| PackScore = 1E+30 + CDbl(notPlaced) * 1E+25 | |
| Exit Function | |
| End If | |
| ' -------------------------------------------------------- | |
| ' RIGHT WASTE | |
| ' -------------------------------------------------------- | |
| excessRight = rightWaste - MAX_RIGHT_WASTE | |
| If excessRight < 0# Then | |
| excessRight = 0# | |
| End If | |
| ' -------------------------------------------------------- | |
| ' ALIGNMENT NORMALIZATION | |
| ' -------------------------------------------------------- | |
| alignmentNormalized = alignmentScore | |
| ' -------------------------------------------------------- | |
| ' FINAL SCORE | |
| ' | |
| ' Right waste excess is deliberately very expensive. | |
| ' Material is still the main objective after satisfying | |
| ' the 10 cm right-edge target. | |
| ' -------------------------------------------------------- | |
| PackScore = _ | |
| excessRight * 100000000# + _ | |
| materialUsed + _ | |
| alignmentNormalized * 0.01 + _ | |
| CDbl(rollCount) * 0.0001 | |
| End Function | |
| ' ============================================================ | |
| ' MOVE SHAPE TO BOTTOM LEFT | |
| ' ============================================================ | |
| Private Sub MoveShapeToBottomLeft(ByVal sh As Shape, ByVal targetX As Double, ByVal targetY As Double) | |
| Dim bx As Double | |
| Dim by As Double | |
| Dim bw As Double | |
| Dim bh As Double | |
| sh.GetBoundingBox bx, by, bw, bh, False | |
| sh.Move targetX - bx, targetY - by | |
| End Sub | |
| ' ============================================================ | |
| ' APPLY NESTING TO REAL OBJECTS | |
| ' ============================================================ | |
| Private Sub ApplyNestingToObjects(ByRef items() As TBanner, ByRef sourceShapes() As Shape, ByRef rolls() As TRoll, ByVal rollCount As Long, ByVal rollWidth As Double) | |
| Dim totalHeight As Double | |
| Dim rollOffsetY As Double | |
| Dim r As Long | |
| Dim i As Long | |
| Dim rid As Long | |
| Dim margin As Double | |
| Dim targetX As Double | |
| Dim targetY As Double | |
| Dim pageLeft As Double | |
| Dim pageBottom As Double | |
| Dim sh As Shape | |
| totalHeight = 0# | |
| For r = 1 To rollCount | |
| totalHeight = totalHeight + rolls(r).UsedHeight | |
| If r < rollCount Then | |
| totalHeight = totalHeight + ROLL_GAP | |
| End If | |
| Next r | |
| If totalHeight <= EPS Then | |
| totalHeight = 10# | |
| End If | |
| ActivePage.SizeWidth = rollWidth | |
| ActivePage.SizeHeight = totalHeight | |
| pageLeft = ActivePage.LeftX | |
| pageBottom = ActivePage.BottomY | |
| rollOffsetY = 0# | |
| For r = 1 To rollCount | |
| For i = 1 To rolls(r).placedCount | |
| rid = rolls(r).placed(i).rid | |
| Set sh = sourceShapes(rid) | |
| margin = items(rid).margin | |
| If rolls(r).placed(i).Rotated Then | |
| sh.Rotate 90# | |
| End If | |
| targetX = pageLeft + rolls(r).placed(i).x + margin | |
| targetY = pageBottom + rollOffsetY + rolls(r).UsedHeight - rolls(r).placed(i).y - rolls(r).placed(i).h + margin | |
| MoveShapeToBottomLeft sh, targetX, targetY | |
| Next i | |
| rollOffsetY = _ | |
| rollOffsetY + _ | |
| rolls(r).UsedHeight + _ | |
| ROLL_GAP | |
| Next r | |
| ActiveDocument.ClearSelection | |
| For r = 1 To rollCount | |
| For i = 1 To rolls(r).placedCount | |
| rid = rolls(r).placed(i).rid | |
| sourceShapes(rid).CreateSelection | |
| Next i | |
| Next r | |
| End Sub | |
| ' ============================================================ | |
| ' PARSE ROLL WIDTH LIST | |
| ' ============================================================ | |
| Private Sub ParseWidthList(ByVal txt As String, ByRef widths() As Double, ByRef widthCount As Long) | |
| Dim parts() As String | |
| Dim i As Long | |
| Dim v As Double | |
| widthCount = 0 | |
| parts = Split(txt, ",") | |
| ReDim widths(1 To UBound(parts) + 1) | |
| For i = LBound(parts) To UBound(parts) | |
| If Len(Trim$(parts(i))) > 0 Then | |
| v = Val(Trim$(parts(i))) | |
| If v > 0# Then | |
| widthCount = widthCount + 1 | |
| widths(widthCount) = v | |
| End If | |
| End If | |
| Next i | |
| If widthCount <= 0 Then | |
| ReDim widths(1 To 1) | |
| Else | |
| ReDim Preserve widths(1 To widthCount) | |
| End If | |
| End Sub | |
| ' ============================================================ | |
| ' SORT MODE NAME | |
| ' ============================================================ | |
| Private Function SortModeName(ByVal mode As Long) As String | |
| Select Case mode | |
| Case 1 | |
| SortModeName = "Area Descending" | |
| Case 2 | |
| SortModeName = "Width Descending" | |
| Case 3 | |
| SortModeName = "Height Descending" | |
| Case 4 | |
| SortModeName = "Short Side Descending" | |
| Case 5 | |
| SortModeName = "Long Side Descending" | |
| Case 6 | |
| SortModeName = "Aspect Ratio Descending" | |
| Case Else | |
| SortModeName = "Unknown" | |
| End Select | |
| End Function | |
| ' ============================================================ | |
| ' FIT MODE NAME | |
| ' ============================================================ | |
| Private Function FitModeName(ByVal mode As Long) As String | |
| Select Case mode | |
| Case 1 | |
| FitModeName = "BSSF" | |
| Case 2 | |
| FitModeName = "BAF" | |
| Case 3 | |
| FitModeName = "BLSF" | |
| Case 4 | |
| FitModeName = "Contact Point" | |
| Case Else | |
| FitModeName = "Unknown" | |
| End Select | |
| End Function | |
| ' ============================================================ | |
| ' MAIN | |
| ' ============================================================ | |
| Public Sub RunNesting_BannerCorelDRAW() | |
| Dim doc As Document | |
| Dim sr As ShapeRange | |
| Dim sh As Shape | |
| Dim items() As TBanner | |
| Dim sourceShapes() As Shape | |
| Dim rolls() As TRoll | |
| Dim candidateRolls() As TRoll | |
| Dim n As Long | |
| Dim i As Long | |
| Dim j As Long | |
| Dim oldUnit As Long | |
| Dim margin As Double | |
| Dim rollText As String | |
| Dim widths() As Double | |
| Dim widthCount As Long | |
| Dim rotateAnswer As VbMsgBoxResult | |
| Dim allowRotation As Boolean | |
| Dim maxHeight As Double | |
| Dim minNeeded As Double | |
| Dim candidateWidth As Double | |
| Dim bestWidth As Double | |
| Dim candidateSortMode As Long | |
| Dim candidateFitMode As Long | |
| Dim bestSortMode As Long | |
| Dim bestFitMode As Long | |
| Dim candidateRollCount As Long | |
| Dim candidateNotPlaced As Long | |
| Dim bestRollCount As Long | |
| Dim bestNotPlaced As Long | |
| Dim candidateScore As Double | |
| Dim bestScore As Double | |
| Dim candidateMaterial As Double | |
| Dim bestMaterial As Double | |
| Dim candidateWaste As Double | |
| Dim bestWaste As Double | |
| Dim candidateRightWaste As Double | |
| Dim bestRightWaste As Double | |
| Dim candidateAlignment As Double | |
| Dim bestAlignment As Double | |
| Dim bx As Double | |
| Dim by As Double | |
| Dim bw As Double | |
| Dim bh As Double | |
| Dim sumSide As Double | |
| Dim maxMargin As Double | |
| Dim msg As String | |
| ' ======================================================== | |
| ' DOCUMENT CHECK | |
| ' ======================================================== | |
| If ActiveDocument Is Nothing Then | |
| MsgBox "Tidak ada document CorelDRAW aktif.", vbExclamation, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| Set doc = ActiveDocument | |
| ' ======================================================== | |
| ' SELECTION CHECK | |
| ' ======================================================== | |
| Set sr = ActiveSelectionRange | |
| If sr Is Nothing Then | |
| MsgBox "Pilih object/banner terlebih dahulu.", vbExclamation, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| If sr.count <= 0 Then | |
| MsgBox "Pilih minimal 1 object/banner terlebih dahulu.", vbExclamation, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| n = sr.count | |
| ' ======================================================== | |
| ' UNIT | |
| ' ======================================================== | |
| oldUnit = doc.Unit | |
| doc.Unit = cdrCentimeter | |
| ' ======================================================== | |
| ' READ OBJECTS | |
| ' ======================================================== | |
| ReDim items(1 To n) | |
| ReDim sourceShapes(1 To n) | |
| i = 0 | |
| For Each sh In sr | |
| i = i + 1 | |
| Set sourceShapes(i) = sh | |
| sh.GetBoundingBox bx, by, bw, bh, False | |
| If bw <= EPS Or bh <= EPS Then | |
| doc.Unit = oldUnit | |
| MsgBox "Object nomor " & CStr(i) & " memiliki bounding box tidak valid.", vbCritical, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| items(i).Label = "Object " & CStr(i) | |
| items(i).OrigW = bw | |
| items(i).OrigH = bh | |
| items(i).margin = 0# | |
| Next sh | |
| ' ======================================================== | |
| ' MARGIN | |
| ' ======================================================== | |
| margin = Val(InputBox("Margin / clearance per sisi (cm):", "Auto Nesting - Margin", "0")) | |
| If margin < 0# Then | |
| margin = 0# | |
| End If | |
| For i = 1 To n | |
| items(i).margin = margin | |
| Next i | |
| ' ======================================================== | |
| ' ROLL WIDTH | |
| ' ======================================================== | |
| rollText = InputBox("Masukkan daftar lebar roll dalam cm." & vbCrLf & "Contoh: 150,200,250,300", "Auto Nesting - Roll Width", "109, 159, 219, 259, 319") | |
| If Len(Trim$(rollText)) = 0 Then | |
| doc.Unit = oldUnit | |
| MsgBox "Lebar roll tidak diberikan.", vbExclamation, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| ParseWidthList rollText, widths, widthCount | |
| If widthCount <= 0 Then | |
| doc.Unit = oldUnit | |
| MsgBox "Daftar lebar roll tidak valid.", vbCritical, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| ' ======================================================== | |
| ' ROTATION | |
| ' ======================================================== | |
| rotateAnswer = MsgBox("Izinkan object diputar 90°?", vbYesNo + vbQuestion, "Auto Nesting - Rotation") | |
| allowRotation = (rotateAnswer = vbYes) | |
| ' ======================================================== | |
| ' MAX HEIGHT | |
| ' ======================================================== | |
| sumSide = 0# | |
| maxMargin = 0# | |
| For i = 1 To n | |
| sumSide = sumSide + MaxD(items(i).OrigW, items(i).OrigH) | |
| maxMargin = MaxD(maxMargin, items(i).margin) | |
| Next i | |
| maxHeight = sumSide + maxMargin * (n + 2) + 100# | |
| ' ======================================================== | |
| ' MINIMUM ROLL WIDTH | |
| ' ======================================================== | |
| minNeeded = 0# | |
| For i = 1 To n | |
| If allowRotation Then | |
| minNeeded = MaxD(minNeeded, MinD(items(i).OrigW, items(i).OrigH) + 2# * items(i).margin) | |
| Else | |
| minNeeded = MaxD(minNeeded, items(i).OrigW + 2# * items(i).margin) | |
| End If | |
| Next i | |
| ' ======================================================== | |
| ' INITIAL BEST | |
| ' ======================================================== | |
| bestScore = 1E+30 | |
| bestMaterial = 1E+30 | |
| bestWaste = 1# | |
| bestRightWaste = 1E+30 | |
| bestAlignment = 1E+30 | |
| bestWidth = 0# | |
| bestRollCount = 0 | |
| bestNotPlaced = n | |
| bestSortMode = 1 | |
| bestFitMode = 1 | |
| ' ======================================================== | |
| ' MULTI-START | |
| ' | |
| ' Each roll width: | |
| ' | |
| ' 6 sorting methods | |
| ' x | |
| ' 4 fitness methods (BSSF, BAF, BLSF, Contact Point) | |
| ' | |
| ' = 24 configurations per roll width | |
| ' ======================================================== | |
| For j = 1 To widthCount | |
| candidateWidth = widths(j) | |
| If candidateWidth + EPS >= minNeeded Then | |
| For candidateSortMode = 1 To 6 | |
| For candidateFitMode = 1 To 4 | |
| PackMultiRoll items, n, candidateWidth, maxHeight, allowRotation, candidateSortMode, candidateFitMode, candidateRolls, candidateRollCount, candidateNotPlaced | |
| candidateScore = PackScore(items, candidateRolls, candidateRollCount, candidateNotPlaced, candidateWidth, candidateRightWaste, candidateAlignment, candidateMaterial) | |
| If candidateNotPlaced = 0 Then | |
| candidateWaste = CalcWaste(items, candidateRolls, candidateRollCount, candidateWidth) | |
| Else | |
| candidateWaste = 1# | |
| End If | |
| If candidateScore < bestScore Then | |
| bestScore = candidateScore | |
| bestWidth = candidateWidth | |
| bestRollCount = candidateRollCount | |
| bestNotPlaced = candidateNotPlaced | |
| bestSortMode = candidateSortMode | |
| bestFitMode = candidateFitMode | |
| bestMaterial = candidateMaterial | |
| bestWaste = candidateWaste | |
| bestRightWaste = candidateRightWaste | |
| bestAlignment = candidateAlignment | |
| End If | |
| Next candidateFitMode | |
| Next candidateSortMode | |
| End If | |
| Next j | |
| ' ======================================================== | |
| ' NO RESULT | |
| ' ======================================================== | |
| If bestWidth <= EPS Or bestRollCount <= 0 Then | |
| doc.Unit = oldUnit | |
| msg = "Tidak ditemukan konfigurasi roll yang feasible." | |
| msg = msg & vbCrLf & vbCrLf | |
| msg = msg & "Minimum roll width: " | |
| msg = msg & Format$(minNeeded, "0.00") | |
| msg = msg & " cm" | |
| MsgBox msg, vbCritical, "Auto Nesting" | |
| Exit Sub | |
| End If | |
| ' ======================================================== | |
| ' REPACK WINNING CONFIGURATION | |
| ' ======================================================== | |
| PackMultiRoll items, n, bestWidth, maxHeight, allowRotation, bestSortMode, bestFitMode, rolls, bestRollCount, bestNotPlaced | |
| ' ======================================================== | |
| ' LOCAL SEARCH: REBALANCE BETWEEN ROLLS | |
| ' | |
| ' Tries to drain the last roll into earlier rolls' spare | |
| ' space, reducing roll count / material further when | |
| ' possible. Only runs when the winning configuration | |
| ' already placed everything. | |
| ' ======================================================== | |
| If bestNotPlaced = 0 Then | |
| RebalanceRolls items, rolls, bestRollCount, bestWidth, maxHeight, allowRotation, bestFitMode | |
| End If | |
| ' ======================================================== | |
| ' FINAL METRICS | |
| ' ======================================================== | |
| bestMaterial = CalcMaterialUsed(rolls, bestRollCount, bestWidth) | |
| bestWaste = CalcWaste(items, rolls, bestRollCount, bestWidth) | |
| bestRightWaste = CalcRightWaste(rolls, bestRollCount, bestWidth) | |
| bestAlignment = CalcAlignmentScore(rolls, bestRollCount) | |
| ' ======================================================== | |
| ' APPLY REAL OBJECTS | |
| ' ======================================================== | |
| ApplyNestingToObjects items, sourceShapes, rolls, bestRollCount, bestWidth | |
| ' ======================================================== | |
| ' RESTORE UNIT | |
| ' ======================================================== | |
| doc.Unit = oldUnit | |
| ' ======================================================== | |
| ' RESULT | |
| ' ======================================================== | |
| msg = "AUTO NESTING V3 SELESAI" | |
| msg = msg & vbCrLf & vbCrLf | |
| msg = msg & "Object: " | |
| msg = msg & CStr(n) | |
| msg = msg & vbCrLf | |
| msg = msg & "Roll width: " | |
| msg = msg & Format$(bestWidth, "0.00") | |
| msg = msg & " cm" | |
| msg = msg & vbCrLf | |
| msg = msg & "Jumlah roll: " | |
| msg = msg & CStr(bestRollCount) | |
| msg = msg & vbCrLf | |
| msg = msg & "Tidak ditempatkan: " | |
| msg = msg & CStr(bestNotPlaced) | |
| msg = msg & vbCrLf | |
| msg = msg & "Material digunakan: " | |
| msg = msg & Format$(bestMaterial, "0.00") | |
| msg = msg & " cm2" | |
| msg = msg & vbCrLf | |
| msg = msg & "Waste estimasi: " | |
| msg = msg & Format$(bestWaste * 100#, "0.00") | |
| msg = msg & "%" | |
| msg = msg & vbCrLf | |
| msg = msg & "Waste kanan maksimum: " | |
| msg = msg & Format$(bestRightWaste, "0.00") | |
| msg = msg & " cm" | |
| msg = msg & vbCrLf | |
| If bestRightWaste <= MAX_RIGHT_WASTE + EPS Then | |
| msg = msg & "Right waste status: OK" | |
| Else | |
| msg = msg & "Right waste status: > 10 cm" | |
| End If | |
| msg = msg & vbCrLf | |
| msg = msg & "Alignment score: " | |
| msg = msg & Format$(bestAlignment, "0.00") | |
| msg = msg & vbCrLf | |
| msg = msg & "Sort: " | |
| msg = msg & SortModeName(bestSortMode) | |
| msg = msg & vbCrLf | |
| msg = msg & "Fitness: " | |
| msg = msg & FitModeName(bestFitMode) | |
| MsgBox msg, vbInformation, "Auto Nesting V3" | |
| End Sub | |