PSLine2000Documentation/Forms/Utilization on Multiple She...

40 KiB

Utilization on Multiple Sheets

Analysis generated on: 4/1/2025 4:02:13 PM

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

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 BasePrice_LostFocus()
Call CalcIters
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
    lblstatus.Caption = "Building C1 Records"
    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"
   lblstatus.Caption = "Setting Non Zero Usage Parts to Use"
   DoCmd.OpenQuery stDocName, acNormal, acEdit
   UtilResult1.SourceObject = "Util Result1"
   
   stDocName = "Util Set all zero usage parts to ignore"
   lblstatus.Caption = "Setting 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.
   Dim Prices(4), Rg(4, 2)
   
   GoSub InitPricingPerLb

   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
   TotalAw! = 0
   TotalGw! = 0
   TotalPrc! = 0
         
   MainSet.MoveFirst
   Do
      If Not (MainSet.EOF) Then
         If MainSet!Flag <> "1" Then
            FirstValid = 0
            BestWt! = 0
            BestAw! = 0
            BestPrc! = 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)
               Sheet_W = Sheet_Width: GoSub Pricing
               Prc! = Gw! * Price
               If (FirstValid = 0) And (Gw! <> 0) Then
                  BestWt! = Gw!
                  BestAw! = Aw!
                  BestPrc! = Prc!
                  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)
               Sheet_W = Sheet_Width: GoSub Pricing
               Prc! = Gw! * Price
               If (BestPrc! > Prc!) And (Gw! <> 0) Then
                  BestWt! = Gw!
                  BestAw! = Aw!
                  BestPrc! = Prc!
                  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)
            Sheet_W = BestWth!: GoSub Pricing
            Prc! = Gw! * Price
            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
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

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
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)
   
   lblstatus.Caption = "Processing"
    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"
   Command109.Enabled = True
    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
   PurchaseBlank% = ItsAZero(chkPurchaseBlank.Value)
   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
      lblstatus.Caption = "Calculate Gross weight W=" + Format$(BSheet_Width!, "0.00") + "  L=" + Format$(BSheet_Length!, "0.00") + "  E=" + Format$(Terrs!, "0")
      
   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, A) = 0 Then
         ppp = 0
         uuu = 0
      Else
         ppp = BestSS(SetNo, 1, A) / BestSS(SetNo, 2, A)
         uuu = (BestSS(SetNo, 3, A) / BestSS(SetNo, 2, A)) * 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
    Command109.Enabled = False
    Command133.Enabled = False
    lblstatus.Caption = "Obtaining Records"
    Command110.Tag = Command110.Caption
    Command110.Caption = "Processing"
    DoEvents
    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"
    Command133.Enabled = True
    
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 NoOfSheets_LostFocus()
Call CalcIters
End Sub

Private Sub Restore_C1_File_Click()
   tx$ = Trim$(itsaNull$(List158))
   If tx$ <> "" Then

      DoCmd.SetWarnings (False)
      lblstatus.Caption = "Restoring 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"
      lblstatus.Caption = "Done"
 
   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
Private Sub cmdFilteredParts1_Click()
On Error GoTo Err_cmdFilteredParts1_Click

    Dim stDocName As String
    Dim stLinkCriteria As String

    stDocName = "Filtered Parts"
    DoCmd.OpenForm stDocName, , , stLinkCriteria

Exit_cmdFilteredParts1_Click:
    Exit Sub

Err_cmdFilteredParts1_Click:
    MsgBox Err.Description
    Resume Exit_cmdFilteredParts1_Click
    
End Sub

What it does

Code Description

This VBA code is written in Microsoft Excel and appears to be part of a larger application related to material utilization and cost calculation. The code consists of several subroutines that perform the following tasks:

CalcIters Subroutine


This subroutine calculates the number of iterations required for sheet size calculations based on width and length increments. It takes into account any existing width or length increment values.

  1. Calculates the absolute differences in width (sz1) and length (sz2) between the beginning and end points.
  2. Divides sz1 by the absolute value of the current width increment (IncWidth) if applicable.
  3. Increments sz1 by 1 to account for the next iteration.
  4. Calculates the product of sz1 and sz2.
  5. Formats the result as a string with leading zeros.

cmdButtnCalc_Click Subroutine


This subroutine performs the main calculation process when the command button is clicked. It:

  1. Retrieves database connections and recordsets for material utilization data.
  2. Purges any existing AS400 product number files from the databases.
  3. Purges any existing result files from the second database.
  4. Activates an AS400 program using a macro.
  5. Runs another macro to retrieve results from the AS400 system.
  6. Updates labels with status messages throughout the process.

Command25_Click Subroutine


This subroutine is used to perform calculations for sheet size, density, and total weight when the command button is clicked again. It:

  1. Retrieves database connections and recordsets for material utilization data.
  2. Sets up variables for width, length, and increment values based on previous input values.
  3. Calculates the total gross weight (TotalGw!) by iterating through different sheet sizes.
  4. Updates a label with the current status message during the calculation process.
  5. Exits the subroutine if no density value is entered.

Common Variables and Constants


The code uses several variables and constants to store input values, intermediate results, and calculated values, including:

  • fromar, toar, curar, CurrSetSize, CurrSetGw, CurrSetAw, and BestSS arrays to store sheet size data.
  • BegWidth, EndWidth, IncWidth, BegLength, EndLength, ICL, Density, TotalGw!, SheetWidth, SheetLength, LGrossWt, LSheetL, LSheetW, and Cost variables to store input values, intermediate results, and calculated values.
  • lblstatus and Command25 labels to display status messages.

Macros Used


The code references several macros, including:

  • Material Selections for Utilitzation
  • AS400 Utiliz Results
  • DoEvents

These macros are likely defined elsewhere in the application and perform specific tasks related to material utilization and cost calculation.