I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

# Knapsack Problem/Visual Basic

Knapsack Problem/Visual Basic is part of Knapsack Problem. You may find other members of Knapsack Problem at Category:Knapsack Problem.
Works with: Visual Basic version 6.0
`Option Explicit Type TreasureType    Name As String    Units As String    Value As Currency    weight As Single    Volume As SingleEnd Type Type SolutionType    Desc As String    Value As CurrencyEnd Type Type KnapsackType    Contents() As Integer    CapacityWeight As Single    CapacityVolume As SingleEnd Type Dim Treasures() As TreasureType Public Sub Main()     SetupTreasureShangriLa    Debug.Print CalcKnapsack(25, 0.25) End Sub Public Sub SetupTreasureShangriLa()     ReDim Treasures(3) As TreasureType    With Treasures(1)        .Name = "panacea"        .Units = "vials"        .Value = 3000        .weight = 0.3        .Volume = 0.025    End With    With Treasures(2)        .Name = "ichor"        .Units = "ampules"        .Value = 1800        .weight = 0.2        .Volume = 0.015    End With    With Treasures(3)        .Name = "gold"        .Units = "bars"        .Value = 2500        .weight = 2        .Volume = 0.002    End With End Sub Public Function CalcKnapsack(ByVal sCapacityWeight As Single, ByVal sCapacityVolume As Single) As StringDim Knapsack As KnapsackTypeDim Solution As SolutionType     Knapsack.CapacityVolume = sCapacityVolume    Knapsack.CapacityWeight = sCapacityWeight    ReDim Knapsack.Contents(UBound(Treasures)) As Integer    Call Stuff(Knapsack, Solution, 1)    Debug.Print "Maximum value: " & Solution.Value    Debug.Print "Ideal Packing(s): " & vbCrLf & Solution.Desc End Function Private Sub Stuff(ByRef Knapsack As KnapsackType, ByRef Solution As SolutionType, ByVal nDepth As Integer)Dim nI As IntegerDim curVal As CurrencyDim sWeightRemaining As SingleDim sVolumeRemaining As SingleDim nJ As Integer     sWeightRemaining = CalcWeightRemaining(Knapsack)    sVolumeRemaining = CalcvolumeRemaining(Knapsack)     With Treasures(nDepth)        If nDepth = UBound(Treasures) Then            Knapsack.Contents(nDepth) = Min(Fix(sWeightRemaining / .weight), Fix(sVolumeRemaining / .Volume))            curVal = CalcValue(Knapsack)            If curVal > Solution.Value Then                Solution.Value = curVal                Solution.Desc = BuildDesc(Knapsack)            ElseIf curVal = Solution.Value Then                Solution.Desc = Solution.Desc & vbCrLf & "or" & vbCrLf & vbCrLf & BuildDesc(Knapsack)            End If        Else            For nI = 0 To Min(Fix(sWeightRemaining / .weight), Fix(sVolumeRemaining / .Volume))                Knapsack.Contents(nDepth) = nI                For nJ = nDepth + 1 To UBound(Treasures)                    Knapsack.Contents(nJ) = 0                Next nJ                Call Stuff(Knapsack, Solution, nDepth + 1)            Next nI        End If    End With End Sub Private Function CalcValue(ByRef Knapsack As KnapsackType) As CurrencyDim curTmp As CurrencyDim nI As Integer     For nI = 1 To UBound(Treasures)        curTmp = curTmp + (Treasures(nI).Value * Knapsack.Contents(nI))    Next nI     CalcValue = curTmp End Function Private Function Min(ByVal vA As Variant, ByVal vB As Variant) As Variant     If vA < vB Then        Min = vA    Else        Min = vB    End If End Function Private Function CalcWeightRemaining(ByRef Knapsack As KnapsackType) As SingleDim sTmp As SingleDim nI As Integer     For nI = 1 To UBound(Treasures)        sTmp = sTmp + (Treasures(nI).weight * Knapsack.Contents(nI))    Next nI     CalcWeightRemaining = Knapsack.CapacityWeight - sTmp End Function Private Function CalcvolumeRemaining(ByRef Knapsack As KnapsackType) As SingleDim sTmp As SingleDim nI As Integer     For nI = 1 To UBound(Treasures)        sTmp = sTmp + (Treasures(nI).Volume * Knapsack.Contents(nI))    Next nI     CalcvolumeRemaining = Knapsack.CapacityVolume - sTmp End Function Private Function BuildDesc(ByRef Knapsack As KnapsackType) As StringDim cTmp As StringDim nI As Integer     For nI = 1 To UBound(Treasures)        cTmp = cTmp & Knapsack.Contents(nI) & " " & Treasures(nI).Units & " of " & Treasures(nI).Name & vbCrLf    Next nI    BuildDesc = cTmp End Function`

Output:

```Maximum value: 54500
Ideal Packing(s):
0 vials of panacea
15 ampules of ichor
11 bars of gold

or

3 vials of panacea
10 ampules of ichor
11 bars of gold

or

6 vials of panacea
5 ampules of ichor
11 bars of gold

or

9 vials of panacea
0 ampules of ichor
11 bars of gold```