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