# Delete this --- ## Record Source - *None* ## Controls | Control Name | Reference | |--------------|-----------| | List86 (Row Source) | | | Combo12 (Row Source) | [[Tables/[Metals];]] | | TypeofMetal (Row Source) | [[Tables/[MetalPrices]] | | GaugeOfType (Row Source) | [[Tables/MetalPrices]] | | List158 (Row Source) | | | Combo165 (Row Source) | [[Tables/[Base]] | | Combo168 (Row Source) | [[Tables/[Sheets]] | ## VBA Code ```vba Option Compare Database Dim fromar(10), toar(10), curar(10), CurrSetSize(10), CurrSetGw(10), CurrSetAw(10), Sheets Dim BestSS(10, 3, 6) ' | ' +---------------------> 0 - Sheet Size ' 1 - Price for sheet ' 2 - Pounds used Gw ' 3 - Aw ' Private Sub ActiveXCtl24_Click() End Sub Private Sub ActiveXCtl24_CommandComplete(ByVal returnValue As Long) End Sub Private Sub BegLength_LostFocus() Call CalcIters End Sub Private Sub BegWidth_LostFocus() Call CalcIters End Sub Private Sub CalcIters() sz1 = Abs(EndWidth - BegWidth) If IncWidth <> 0 Then sz1 = sz1 / Abs(IncWidth) End If sz1 = sz1 + 1 sz2 = Abs(EndLength - BegLength) If IncLength <> 0 Then sz2 = sz2 / Abs(IncLength) End If sz2 = sz2 + 1 sz1 = sz1 * sz2 Iterations = Format$(sz1, "0") End Sub Private Sub cmdButtnCalc_Click() Dim MainDB As Database, MainSet As Recordset Dim MainDB2 As Database, MainSet2 As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainDB2 = DBEngine.Workspaces(0).Databases(0) lblstatus.Caption = "Selecting Parts for Material Utilization" DoCmd.RunMacro "Material Selections for Utilitzation" lblstatus.Caption = "Selection Complete" Refresh lblstatus.Caption = "Moving Parts to AS400" Set MainSet = MainDB.OpenRecordset("RMSFILES#_IEMUP1A0") ' Create dynaset. Set MainSet2 = MainDB2.OpenRecordset("Util Selection 2") ' Create dynaset. lblstatus.Caption = "Purging AS400 product number file" MainSet.MoveFirst Do If Not (MainSet.EOF) Then MainSet.Delete DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop lblstatus.Caption = "Purging AS400 result file" MainSet2.MoveFirst Do If Not (MainSet2.EOF) Then p$ = MainSet2!prt MainSet.AddNew MainSet!PRDNO = p$ MainSet.Update DoEvents Else DoEvents Exit Do End If MainSet2.MoveNext Loop lblstatus.Caption = "Activating AS400 Program" DoEvents ActiveXCtl24.DoClick lblstatus.Caption = "Retrieving Results" UtilResult1.SourceObject = "tricks" DoCmd.RunMacro "AS400 Utiliz Results" UtilResult1.SourceObject = "Util Result1" ' lblStatus.Caption = "Calculating material utilization on parts" lblstatus.Caption = "Done" End Sub Private Sub Command25_Click() Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util Matrix") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Exit Sub End If First = True For Sheet_Width! = BGW! To EDW! Step ICW! For Sheet_Length! = BGL! To EDL! Step ICL! SheetWidth = Sheet_Width! SheetLength = Sheet_Length! GoSub DoSheetSize Main2Set.AddNew Main2Set!Gw = TotalGw! Main2Set!SheetL = SheetLength Main2Set!sheetw = SheetWidth Main2Set.Update If (First) Or (LGrossWt > TotalGw!) Then LGrossWt = TotalGw! LSheetL = SheetLength LSheetW = SheetWidth First = False End If Next Next Cost = 0 Exit Sub DoSheetSize: lblstatus.Caption = "Calculate Gross Weight for all parts at this sheet" TotalGw! = 0 MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> 1 Then Sheet_Width! = SheetWidth Sheet_Length! = SheetLength Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) TotalGw! = Gw! + TotalGw! End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Return End Sub Private Sub Command43_Click() On Error GoTo Err_Command43_Click Call Form.Command120_Click ' DoCmd.GoToRecord acDataForm, "UtilResult1", acNext Exit_Command43_Click: Exit Sub Err_Command43_Click: MsgBox Err.Description Resume Exit_Command43_Click End Sub Private Sub Command55_Click() lblstatus.Caption = "Running Query to pick parts for Material Utilization" DoCmd.RunMacro "Filter across Materials Utilitzation" lblstatus.Caption = "Selection Complete" Refresh End Sub Private Sub BestSheets_Click() Call GetTheBestAnswers End Sub Private Sub cmdCreate_Click() Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util L X W") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength For Sheet_Width! = BGW! To EDW! Step ICW! For Sheet_Length! = BGL! To EDL! Step ICL! MainSet.AddNew MainSet!SheetL = Sheet_Length! MainSet!sheetw = Sheet_Width! MainSet.Update Next Next Refresh End Sub Private Sub cmdLengths_Click() SheetWidths! = Val(AddWidths) Call Addparms(2, SheetWidths!) Refresh End Sub Private Sub cmdWidths_Click() SheetLength! = Val(AddLengths) Call Addparms(1, SheetLength!) Refresh End Sub Private Sub Combo12_Change() A$ = UCase$(Combo12.Column(1)) typ$ = "" If InStr(A$, "S/S") <> 0 Then typ$ = "S/S" If InStr(A$, "C/R") <> 0 Then typ$ = "C/R" If InStr(A$, "COLD ROLL") <> 0 Then typ$ = "C/R" If InStr(A$, "ALUMINIUM") <> 0 Then typ$ = "ALZ" If InStr(A$, "ALZ") <> 0 Then typ$ = "ALZ" TypeofMetal = typ$ GaugeOfType = Left$(Combo12.Column(2), 2) Density = Combo12.Column(3) End Sub Private Sub Command109_Click() On Error GoTo Err_Command109_Click Dim stDocName As String Command109.Tag = Command109.Caption Command109.Caption = "Processing" DoEvents DoCmd.SetWarnings (False) lblstatus.Caption = "Building C1 Records" ' stDocName = "Util Make Select 1" ' DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "tricks" If Frame111 = 1 Then stDocName = "Util Result2" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" Else stDocName = "Util Result3" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" End If UtilResult1.SourceObject = "tricks" stDocName = "Util Set non zero usage parts to use" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" stDocName = "Util Set all zero usage parts to ignore" DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "Util Result1" Exit_Command109_Click: lblstatus.Caption = "Done" Command109.Caption = Command109.Tag Exit Sub Err_Command109_Click: MsgBox Err.Description Resume Exit_Command109_Click End Sub Private Sub Command122_Click() ' Dim MainDB As Database, MainSet As Recordset Dim sh%(10), sl!(10), Sw!(10), desc$(10) Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Command79.Enabled = True Exit Sub End If Sheets = Val(itsaNull$(NoOfSheets)) a1$ = itsaNull$(FavoriteSet) For i = 1 To Sheets sh%(i) = Val(a1$) cm = InStr(a1$, ",") If cm <> 0 Then a1$ = Mid$(a1$, cm + 1) Else a1$ = "" End If If sh%(i) <> 0 Then Key$ = Right$("0000000000" + Trim$(Str$(sh%(i))), 10) GoSub GetSheetSizer sl!(i) = Sheet_Length! Sw!(i) = Sheet_Width! desc$(i) = Format$(Sheet_Width!, "0.0") + " X " + Format$(Sheet_Length!, "0.0") Else sl!(i) = 0 Sw!(i) = 0 desc$(i) = "" End If Next ' SetNo TotalGw! = 0 MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then FirstValid = 0 BestWt! = 0 BestSheet = 0 Bestlen! = 0 BestWth! = 0 For SetNo = 1 To Sheets Sheet_Length! = sl!(SetNo) Sheet_Width! = Sw!(SetNo) Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) If (FirstValid = 0) And (Gw! <> 0) Then BestWt! = Gw! BestSheet = SetNo Bestlen! = Sheet_Length! BestWth! = Sheet_Width! FirstValid = 1 Exit For End If Next For SetNo = 1 To Sheets Sheet_Length! = sl!(SetNo) Sheet_Width! = Sw!(SetNo) Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) If (BestWt! > Gw!) And (Gw! <> 0) Then BestWt! = Gw! BestSheet = SetNo Bestlen! = Sheet_Length! BestWth! = Sheet_Width! End If Next A$ = MainSet!PartNumber Call UtilGrossWt(BestWth!, Bestlen!, lb_per_sq_ft!, Gw!, Aw!, MainSet) MainSet.Edit If BestSheet = 0 Then MainSet!BestSheetSet = "BAD SHEETSET" Else MainSet!BestSheetSet = desc$(BestSheet) End If MainSet!GrossWt = Gw! MainSet!ActualWt = Aw! MainSet.Update End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Exit Sub GetSheetSizer: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return End Sub Private Sub Command130_Click() tx$ = Trim$(itsaNull$(txtSaveAs)) If tx$ <> "" Then DoCmd.CopyObject , tx$, acTable, "Util Selection C1" End If End Sub Private Sub Command133_Click() Dim MainDB As Database, MainSet As Recordset Dim MainDB2 As Database, MainSet2 As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainDB2 = DBEngine.Workspaces(0).Databases(0) Command133.Tag = Command133.Caption Command133.Caption = "Processing" DoEvents lblstatus.Caption = "Selecting Parts for Material Utilization" DoCmd.RunMacro "Material Selections for Utilitzation" lblstatus.Caption = "Selection Complete" Refresh lblstatus.Caption = "Moving Parts to AS400" Set MainSet = MainDB.OpenRecordset("RMSFILES#_IEMUP1A0") ' Create dynaset. Set MainSet2 = MainDB2.OpenRecordset("Util Selection 2") ' Create dynaset. lblstatus.Caption = "Purging AS400 product number file" On Error Resume Next MainSet.MoveFirst On Error GoTo 0 Do If Not (MainSet.EOF) Then MainSet.Delete DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop lblstatus.Caption = "Purging AS400 result file" MainSet2.MoveFirst Do If Not (MainSet2.EOF) Then p$ = MainSet2!prt MainSet.AddNew MainSet!PRDNO = p$ MainSet.Update DoEvents Else DoEvents Exit Do End If MainSet2.MoveNext Loop lblstatus.Caption = "Activating AS400 Program" DoEvents ActiveXCtl24.DoClick lblstatus.Caption = "Retrieving Results" UtilResult1.SourceObject = "tricks" DoCmd.RunMacro "AS400 Utiliz Results" UtilResult1.SourceObject = "Util Result1" ' lblStatus.Caption = "Calculating material utilization on parts" lblstatus.Caption = "Done" Command133.Caption = Command133.Tag End Sub Private Sub Command136_Click() UtilResult1.SourceObject = "tricks" UtilResult1.SourceObject = "Util Result1" End Sub Private Sub Command67_Click() Cost = PricePerPound * LGrossWt End Sub Private Sub Command68_Click() lblstatus.Caption = "Emptying Util Matrix" DoCmd.CopyObject "Util L X W", acTable, "Util Matrix Zero" End Sub Private Sub Command79_Click() ' Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util Selection C1") ' Create dynaset. Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Dim Prices(4), Rg(4, 2) GoSub InitPricingPerLb Command79.Tag = Command79.Caption Command79.Caption = "Processing" DoEvents Main2Set.Index = "Primary Key" LGrossWt.SetFocus Command79.Enabled = False lb_per_sq_ft! = Density If lb_per_sq_ft! = 0 Then Call MsgBox("No density entered.") Command79.Enabled = True Exit Sub End If Sheets = Val(itsaNull$(NoOfSheets)) If Sheets > 10 Then MsgBox ("Too Many Sheets") Command79.Enabled = True Exit Sub End If If Sheets < 1 Then MsgBox ("No Sheets Entered") Command79.Enabled = True Exit Sub End If MainSet.MoveFirst Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then If Val(itsaNull(MainSet!USAGE)) = 0 Then PN$ = MainSet!PartNumber MsgBox ("USAGE=0 for Partnumber: " + PN$) Command79.Enabled = True Exit Sub End If End If Else Exit Do End If MainSet.MoveNext Loop For SetNo = 0 To 10 For i = 0 To 3 For j = 0 To 6 BestSS(SetNo, i, j) = 0 Next Next 'CurrSetSize(SetNo) = 0 Next Cost = 0 ' ' Count up the number of iterations to go through ' NoOfIters% = 0 lblstatus.Caption = "Numbering Iterations" Main2Set.MoveLast Main2Set.Edit Main2Set!idno = "AAA" Main2Set.Update Main2Set.MoveFirst Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Do If Not (Main2Set.EOF) Then NoOfIters% = NoOfIters% + 1 Main2Set.Edit Main2Set!idno = Right$("0000000000" + Trim$(Str$(NoOfIters%)), 10) Main2Set.Update DoEvents Else DoEvents Exit Do End If Main2Set.MoveNext If Not (Main2Set.EOF) Then If (Main2Set!idno = "AAA") Then NoOfIters% = NoOfIters% + 1 Main2Set.Edit Main2Set!idno = Right$("0000000000" + Trim$(Str$(NoOfIters%)), 10) Main2Set.Update Exit Do End If End If Loop Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" lblstatus.Caption = "Calculate Gross weight" If NoOfIters% < Sheets Then MsgBox ("Not Enough Iterations") Command79.Enabled = True Exit Sub End If Iterations = NoOfIters% GoSub Init_Iterations FirstIter = True If NoOfIters% <> 1 Then Do GoSub CalcGWforSet ind = Sheets Do ' This loop bumps the CPH (current place holder) curar(ind) = curar(ind) + 1 If curar(ind) > toar(ind) Then ' IF the CPH exceed the limit fromar(ind) = fromar(ind) + 1 ' start the CPH at the from+1 curar(ind) = fromar(ind) ' and dec back to the prev PH ind = ind - 1 Else ib = curar(ind) ' Otherwise, all PH to the rt For ix = ind To Sheets ' should = CPH+1 curar(ix) = ib ib = ib + 1 Next Exit Do ' done End If Loop dn = 0 For ind = 1 To Sheets ' Check to see if all PHs If curar(ind) <> toar(ind) Then ' = the last toPHs dn = 1 ' if not loop to top Exit For End If Next If dn = 0 Then ' if so do the last one Exit Do End If Loop Else End If GoSub CalcGWforSet Main2Set.MoveFirst Do If Not (Main2Set.EOF) Then BSheet_Width! = Val(Main2Set!sheetw) BSheet_Length! = Val(Main2Set!SheetL) GoSub CalcGWforASheet Sheet_W = BSheet_Width: GoSub Pricing Main2Set.Edit Main2Set!ActualWeight = Format$(TotalAw!, "0.00") Main2Set!GrossWeight = Format$(TotalGw!, "0.00") Main2Set!TotalPrice = Format$(TotalGw! * Price, "0.00") Main2Set!ErrCount = Format$(Terrs!, "0") Main2Set.Update DoEvents Else DoEvents Exit Do End If Main2Set.MoveNext Loop CurrentSheetSet = "" a1$ = "" a2$ = "" ttl# = 0 ttlgw# = 0 ttlaw# = 0 a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Gross Wt" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + Chr$(34) + ";" + Chr$(34) + " Util" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(BestSS(SetNo, 0, 0))), 10) GoSub GetSheetSize a1$ = a1$ + " " + Trim$(Str$(Sheet_Width!)) + "X" + Trim$(Str$(Sheet_Length!)) + " =" + Format$(BestSS(SetNo, 1, 0), "$0") a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Width!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Length!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 1, 0), "$##,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 2, 0), "###,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 3, 0), "###,###,##0"), 12) + Chr$(34) + ";" If BestSS(SetNo, 2, 0) = 0 Then ppp = 0 uuu = 0 Else ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0) uuu = (BestSS(SetNo, 3, 0) / BestSS(SetNo, 2, 0)) * 100 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uuu, "###,###,##0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppp, "###,###,##0.00000"), 12) + Chr$(34) + ";" ttl# = ttl# + Val(Format(BestSS(SetNo, 1, 0), "0")) ttlgw# = ttlgw# + Val(Format(BestSS(SetNo, 2, 0), "0")) ttlaw# = ttlaw# + Val(Format(BestSS(SetNo, 3, 0), "0")) Next a2$ = a2$ + Chr$(34) + " " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + "Totals " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttl#, "$##,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlgw#, "###,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlaw#, "###,###,##0"), 12) + Chr$(34) + ";" If ttlgw# <> 0 Then ppx# = ttl# / ttlgw# uux# = (ttlaw# / ttlgw#) * 100 Else ppx# = 0 uux# = 0 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uux#, "##,###,##0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppx#, "##,###,##0.00000"), 12) + Chr$(34) BestSheetSet = a1$ List86.rowSource = a2$ UtilLXW.SourceObject = "tricks" UtilLXW.SourceObject = "Util L X W subform" lblstatus.Caption = "Done" Command79.Enabled = True Command79.Caption = Command79.Tag Exit Sub CalcGWforSet: TotalAw! = 0 TotalGw! = 0 TotalPrc! = 0 a1$ = "" For SetNo = 1 To Sheets a1$ = a1$ + Str$(curar(SetNo)) CurrSetSize(SetNo) = 0 CurrSetGw(SetNo) = 0 CurrSetAw(SetNo) = 0 Next CurrentSheetSet = a1$ MainSet.MoveFirst ' search part file goodset = True Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then ' check the ignore flag BestWt! = 0 BestAw! = 0 BestPrc! = 0 BestSet = 0 For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(curar(SetNo))), 10) GoSub GetSheetSize Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) Sheet_W = Sheet_Width: GoSub Pricing Prc! = Gw! * Price errc = Val(MainSet!CalculationStatus) If errc = 0 Then If (BestPrc! > Prc!) And (Prc! > 0) Then BestWt! = Gw! BestAw! = Aw! BestPrc! = Prc! BestSet = SetNo End If If (BestSet = 0) And (Prc! <> 0) Then BestAw! = Aw! BestWt! = Gw! BestPrc! = Prc! BestSet = SetNo End If End If Next If BestSet = 0 Then goodset = False Exit Do Else TotalAw = BestAw! = TotalAw! TotalGw! = BestWt! + TotalGw! TotalPrc! = BestPrc! + TotalPrc! CurrSetSize(BestSet) = CurrSetSize(BestSet) + BestPrc! CurrSetGw(BestSet) = CurrSetGw(BestSet) + BestWt! CurrSetAw(BestSet) = CurrSetAw(BestSet) + BestAw! End If End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop If goodset Then If FirstIter Then FirstIter = False BestSheetSet = CurrentSheetSet bestsetPrc! = TotalPrc! For top6 = 0 To 6 BestSS(0, 1, top6) = TotalPrc! BestSS(0, 2, top6) = TotalGw! BestSS(0, 3, top6) = TotalAw! Next For SetNo = 1 To Sheets For top6 = 0 To 6 BestSS(SetNo, 0, top6) = curar(SetNo) BestSS(SetNo, 1, top6) = CurrSetSize(SetNo) BestSS(SetNo, 2, top6) = CurrSetGw(SetNo) BestSS(SetNo, 3, top6) = CurrSetAw(SetNo) Next Next End If If (TotalPrc! < BestSS(0, 1, 6)) Then ' if this one is better than then sixth best insert it For worst2best = 5 To 1 Step -1 If (TotalPrc! > BestSS(0, 1, worst2best)) Then For SetNo = 0 To Sheets For top6 = 6 To worst2best + 1 Step -1 BestSS(SetNo, 0, top6) = BestSS(SetNo, 0, top6 - 1) BestSS(SetNo, 1, top6) = BestSS(SetNo, 1, top6 - 1) BestSS(SetNo, 2, top6) = BestSS(SetNo, 2, top6 - 1) BestSS(SetNo, 3, top6) = BestSS(SetNo, 3, top6 - 1) Next Next For SetNo = 1 To Sheets BestSS(SetNo, 0, worst2best + 1) = curar(SetNo) BestSS(SetNo, 1, worst2best + 1) = CurrSetSize(SetNo) BestSS(SetNo, 2, worst2best + 1) = CurrSetGw(SetNo) BestSS(SetNo, 3, worst2best + 1) = CurrSetAw(SetNo) Next BestSS(0, 1, worst2best + 1) = TotalPrc! BestSS(0, 2, worst2best + 1) = TotalGw! BestSS(0, 3, worst2best + 1) = TotalAw! Exit For End If If (TotalPrc! <= BestSS(0, 1, worst2best)) And (worst2best = 1) Then For SetNo = 0 To Sheets For top6 = 6 To worst2best Step -1 BestSS(SetNo, 0, top6) = BestSS(SetNo, 0, top6 - 1) BestSS(SetNo, 1, top6) = BestSS(SetNo, 1, top6 - 1) BestSS(SetNo, 2, top6) = BestSS(SetNo, 2, top6 - 1) BestSS(SetNo, 3, top6) = BestSS(SetNo, 3, top6 - 1) Next Next For SetNo = 1 To Sheets BestSS(SetNo, 0, worst2best) = curar(SetNo) BestSS(SetNo, 1, worst2best) = CurrSetSize(SetNo) BestSS(SetNo, 2, worst2best) = CurrSetGw(SetNo) BestSS(SetNo, 3, worst2best) = CurrSetAw(SetNo) Next BestSS(0, 1, worst2best) = TotalPrc! BestSS(0, 2, worst2best) = TotalGw! BestSS(0, 3, worst2best) = TotalAw! BestSheetSet = CurrentSheetSet BestSS(0, 1, 0) = TotalPrc! For SetNo = 1 To Sheets BestSS(SetNo, 0, 0) = curar(SetNo) BestSS(SetNo, 1, 0) = CurrSetSize(SetNo) BestSS(SetNo, 2, 0) = CurrSetGw(SetNo) BestSS(SetNo, 3, 0) = CurrSetAw(SetNo) Next ' Exit For End If Next End If End If Return GetSheetSize: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return Init_Iterations: For i = 1 To 10 fromar(i) = 0 toar(i) = 0 curar(i) = 0 Next j = Iterations - Sheets For i = 1 To Sheets fromar(i) = i curar(i) = i toar(i) = i + j Next Return CalcGWforASheet: TotalGw! = 0 TotalAw! = 0 Terrs! = 0 MainSet.MoveFirst goodset = True Do If Not (MainSet.EOF) Then If MainSet!Flag <> "1" Then Sheet_Width! = BSheet_Width!: Sheet_Length! = BSheet_Length! Call UtilGrossWt(Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet) errc = Val(MainSet!CalculationStatus) If errc = 0 Then TotalGw! = Gw! + TotalGw! TotalAw! = Aw! + TotalAw! Else goodset = False Terrs! = Terrs! + 1 End If End If DoEvents Else DoEvents Exit Do End If MainSet.MoveNext Loop Return InitPricingPerLb: ' Dim Prices(4), Rg(4, 2) Prices(1) = Val(GaugeOfType.Column(1)) + Val(itsaNull$(BasePrice)) Prices(2) = Val(GaugeOfType.Column(2)) + Val(itsaNull$(BasePrice)) Prices(3) = Val(GaugeOfType.Column(3)) + Val(itsaNull$(BasePrice)) Prices(4) = Val(GaugeOfType.Column(4)) + Val(itsaNull$(BasePrice)) For i = 1 To 4 r$ = TypeofMetal.Column(i) rx = InStr(r$, "-") If rx = 0 Then Exit For Else Rg(i, 1) = Val(Left$(r$, rx - 1)) Rg(i, 2) = Val(Mid$(r$, rx + 1)) End If Next rgx = i - 1 Return 'Sheet_Width!, Sheet_Length!, lb_per_sq_ft!, Gw!, Aw!, MainSet Pricing: Price = -1 For i = 1 To rgx If (Sheet_W >= Rg(i, 1)) And (Sheet_W <= Rg(i, 2)) Then Price = Prices(i) Exit For End If Next If Price = -1 Then MsgBox ("Price range error") Stop End If Return End Sub Sub GiveAnswers(Sheets, XSize, Xincs) For i = 1 To Sheets Print Str$((curar(i) - 1) * Xincs + XSize) + " "; Next Print End Sub Private Sub EndLength_LostFocus() Call CalcIters End Sub Private Sub EndWidth_LostFocus() Call CalcIters End Sub Private Sub Form_Open(Cancel As Integer) Dim MainDB As Database, MainSet As Recordset, tables As TableDef Set MainDB = DBEngine.Workspaces(0).Databases(0) Set tables = MainDB.TableDefs(0) cnt = MainDB.TableDefs.Count bb$ = "" For i = 0 To cnt - 1 Set tables = MainDB.TableDefs(i) bb$ = bb$ + tables.name + ";" Next List158.rowSource = bb$ End Sub Private Sub IncLength_LostFocus() Call CalcIters End Sub Private Sub IncWidth_LostFocus() Call CalcIters End Sub Private Sub cmdOpen14two_Click() On Error GoTo Err_cmdOpen14two_Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "14 two" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_cmdOpen14two_Click: Exit Sub Err_cmdOpen14two_Click: MsgBox Err.Description Resume Exit_cmdOpen14two_Click End Sub Private Sub Addparms(i%, Sizeses!) Dim MainDB As Database, MainSet As Recordset Set MainDB = DBEngine.Workspaces(0).Databases(0) Set MainSet = MainDB.OpenRecordset("Util L X W") ' Create dynaset. BGW! = BegWidth EDW! = EndWidth ICW! = IncWidth BGL! = BegLength EDL! = EndLength ICL! = IncLength If i% = 1 Then BG! = BegWidth ed! = EndWidth IC! = IncWidth Else BG! = BegLength ed! = EndLength IC! = IncLength End If For SS! = BG! To ed! Step IC! If i% = 1 Then SheetWidth! = SS! SheetLength! = Sizeses! Else SheetWidth! = Sizeses! SheetLength! = SS! End If MainSet.AddNew MainSet!SheetL = SheetLength! MainSet!sheetw = SheetWidth! MainSet.Update Next Refresh End Sub Public Sub GetTheBestAnswers() Dim Main2DB As Database, Main2Set As Recordset Set Main2DB = DBEngine.Workspaces(0).Databases(0) Set Main2Set = Main2DB.OpenRecordset("Util L X W") ' Create dynaset. Main2Set.Index = "Primary Key" A = BestSheets If BestSS(1, 0, 0) = 0 Then Exit Sub End If a1$ = "" a2$ = "" ttl# = 0 ttlgw# = 0 ttlaw# = 0 a3$ = "" a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Gross Wt" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + Chr$(34) + ";" + Chr$(34) + " Util" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" For SetNo = 1 To Sheets Key$ = Right$("0000000000" + Trim$(Str$(BestSS(SetNo, 0, A))), 10) GoSub GetTheSheetSize a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Width!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + Trim$(Str$(Sheet_Length!)) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 1, A), "$##,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 2, A), "###,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(BestSS(SetNo, 3, A), "###,###,##0"), 12) + Chr$(34) + ";" If BestSS(SetNo, 2, 0) = 0 Then ppp = 0 uuu = 0 Else ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0) uuu = (BestSS(SetNo, 3, 0) / BestSS(SetNo, 2, 0)) * 100 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uuu, "##,###,##0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppp, "##,###,##0.00000"), 12) + Chr$(34) + ";" ttl# = ttl# + Val(Format(BestSS(SetNo, 1, A), "0")) ttlgw# = ttlgw# + Val(Format(BestSS(SetNo, 2, A), "0")) ttlaw# = ttlaw# + Val(Format(BestSS(SetNo, 3, A), "0")) a3$ = a3$ + Trim$(BestSS(SetNo, 0, A)) + "," Next a3$ = Left$(a3$, Len(a3$) - 1) a2$ = a2$ + Chr$(34) + " " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + "Total " + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttl#, "$##,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlgw#, "##,###,##0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ttlaw#, "##,###,##0"), 12) + Chr$(34) + ";" If ttlgw# <> 0 Then ppx# = ttl# / ttlgw# uux# = (ttlaw# / ttlgw#) * 100 Else ppx# = 0 uux# = 0 End If a2$ = a2$ + Chr$(34) + lpad$(Format$(uux#, "##,###,##0.0"), 12) + Chr$(34) + ";" a2$ = a2$ + Chr$(34) + lpad$(Format$(ppx#, "##,###,##0.00000"), 12) + Chr$(34) List86.rowSource = a2$ FavoriteSet = a3$ Exit Sub GetTheSheetSize: Main2Set.MoveFirst Main2Set.Seek "=", Key$ If Not (Main2Set.NoMatch) Then Sheet_Width! = Val(Main2Set!sheetw) Sheet_Length! = Val(Main2Set!SheetL) End If Return End Sub Private Sub Command108_Click() On Error GoTo Err_Command108_Click Dim stDocName As String Dim stLinkCriteria As String Command108.Tag = Command108.Caption Command108.Caption = "Processing" DoEvents stDocName = "Util Select picker" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_Command108_Click: Command108.Caption = Command108.Tag Exit Sub Err_Command108_Click: MsgBox Err.Description Resume Exit_Command108_Click End Sub Private Sub Command110_Click() On Error GoTo Err_Command110_Click Dim stDocName As String Command110.Tag = Command110.Caption Command110.Caption = "Processing" DoEvents lblstatus.Caption = "Obtaining Records" DoCmd.SetWarnings (False) stDocName = "Util Make Select 0" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Flag Update" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Make Select 1" DoCmd.OpenQuery stDocName, acNormal, acEdit stDocName = "Util Make Select 2" DoCmd.OpenQuery stDocName, acNormal, acEdit lblstatus.Caption = "Done" Exit_Command110_Click: Command110.Caption = Command110.Tag Exit Sub Err_Command110_Click: MsgBox Err.Description Resume Exit_Command110_Click End Sub Private Sub Command134_Click() On Error GoTo Err_Command134_Click x = Detail.BackColor Detail.BackColor = QBColor(15) DoCmd.PrintOut acPages, 1, 1, acHigh, 1 Detail.BackColor = x Exit_Command134_Click: Exit Sub Err_Command134_Click: MsgBox Err.Description Resume Exit_Command134_Click End Sub Private Sub Restore_C1_File_Click() tx$ = Trim$(itsaNull$(List158)) If tx$ <> "" Then DoCmd.SetWarnings (False) lblstatus.Caption = "Copying C1 Records" ' stDocName = "Util Make Select 1" ' DoCmd.OpenQuery stDocName, acNormal, acEdit UtilResult1.SourceObject = "tricks" DoCmd.CopyObject , "Util Selection C1", acTable, tx$ UtilResult1.SourceObject = "Util Result1" End If End Sub Private Sub Misc__Click() On Error GoTo Err_Misc__Click Dim stDocName As String Dim stLinkCriteria As String stDocName = "Miscellaneous" DoCmd.OpenForm stDocName, , , stLinkCriteria Exit_Misc__Click: Exit Sub Err_Misc__Click: MsgBox Err.Description Resume Exit_Misc__Click End Sub ``` ## What it does **Detailed Description of VBA Code** This VBA code is written for a Microsoft Access application and appears to be part of an inventory management system. The code consists of several procedures that perform various tasks, including calculating material utilization on parts, generating reports, and interacting with an AS400 database. ### CalcIters Procedure This procedure calculates the sheet size based on the entered length and width values. It takes into account any increments (IncWidth and IncLength) and rounds up to the nearest integer using the `Abs` function. ```markdown * Calculates sheet size based on length and width values * Takes into account any increments (IncWidth and IncLength) ``` ### cmdButtnCalc_Click Procedure This procedure performs a series of actions when the "Calculate Material Utilization" button is clicked: 1. **Create Dynamic Recordsets**: It creates dynamic recordsets for two databases, `MainDB` and `MainDB2`. 2. **Purge AS400 Product Number File**: It deletes all records from the first dynamic recordset. 3. **Purge AS400 Result File**: It adds new records to the second dynamic recordset based on a specific condition ( prt = MainSet2!prt). 4. **Activate AS400 Program**: It activates an AS400 program using the `ActiveXCtl24` object. 5. **Retrieve Results**: It runs a macro to retrieve results from the AS400 database and populates two reports, `UtilResult1` and `Util Result1`. 6. **Display Status Message**: It updates the status message to indicate that the material utilization calculation is complete. ```markdown * Performs series of actions when Calculate Material Utilization button is clicked * Includes purging AS400 product number file, adding new records to result file, activating program, and retrieving results ``` ### Command25_Click Procedure This procedure performs a similar series of actions as `cmdButtnCalc_Click`, but with some differences: 1. **Create Dynamic Recordsets**: It creates dynamic recordsets for two databases, `MainDB` and `MainDB2`. 2. **Set Initial Values**: It sets initial values for several variables (BegWidth, EndWidth, etc.) based on user input. 3. **Calculate Material Utilization**: It loops through a range of sheet sizes (based on the calculated sheet width and length) and calculates the material utilization using a custom function `DoSheetSize`. 4. **Populate Matrix Recordset**: It adds new records to the second dynamic recordset (Matrix) based on the calculated material utilization. ```markdown * Performs series of actions when another button is clicked * Includes calculating material utilization, looping through sheet sizes, and populating matrix recordset ``` ### DoSheetSize Procedure This procedure is called within `Command25_Click` to calculate the material utilization for a specific sheet size. It takes into account various parameters (such as density) to determine the total weight of materials used. ```markdown * Calculates material utilization for a specific sheet size * Takes into account various parameters (density, etc.) ``` Overall, this VBA code appears to be part of an inventory management system that calculates material utilization on parts based on user input and interacts with an AS400 database.