Cybernomad
/
PSLine2000Documentation
1
0
Fork 0
Code Issues 1 Pull Requests Packages Projects 1 Releases Wiki Activity
PSLine2000Documentation/Forms/Utilization on Multiple She...

1376 lines
40 KiB
Markdown
Raw Blame History

# 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
```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 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.
Reference in New Issue View Git Blame Copy Permalink