Cybernomad
/
PSLine2000Documentation
1
0
Fork 0
Code Issues 1 Pull Requests Packages Projects 1 Releases Wiki Activity
PSLine2000Documentation/Forms/Utilization on MS hold.md

1265 lines
37 KiB
Markdown
Raw Blame History

# Utilization on MS hold
Analysis generated on: 4/1/2025 4:00:27 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]] |
## 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 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
```
## What it does
**VBA Code Description**
This VBA code is written in Excel and appears to be part of a larger application used for material utilization calculations. The code is organized into several subroutines that perform different tasks, such as calculating iterations, selecting parts for material utilization, moving parts to an AS400 system, and calculating sheet sizes.
**CalcIters Subroutine**
This subroutine calculates the number of iterations required to move a certain amount of material along a sheet. It takes into account the width and length of the sheet, as well as any incremental changes (IncWidth and IncLength). The calculation involves:
* Calculating the absolute difference between the end and beginning values for width and length
* Dividing the difference by the increment value (if non-zero)
* Adding 1 to the result
* Squaring the result of the first operation
The number of iterations is then formatted as a zero-padded string and stored in the `Iterations` variable.
**cmdButtnCalc_Click Subroutine**
This subroutine performs several tasks:
1. **Material Selections for Utilitzation**: Runs a macro to select parts for material utilization.
2. **Purging AS400 product number file**: Moves all records from the "RMSFILES#_IEMUP1A0" table in the MainDB database and deletes them.
3. **Purging AS400 result file**: Moves all records from the "Util Selection 2" table in the MainDB2 database, adds new records with the corresponding product number, and updates the existing records.
4. **Activating AS400 Program**: Runs a macro to activate an AS400 program (ActiveXCtl24.DoClick).
5. **Retrieving Results**: Runs another macro to retrieve results from the AS400 system (AS400 Utiliz Results).
The subroutine also updates several variables (`BegWidth`, `EndWidth`, etc.) and uses them to calculate sheet sizes.
**Command25_Click Subroutine**
This subroutine performs several tasks:
1. **Getting MainDB and MainSet**: Opens a database and recordset for material utilization.
2. **Getting Main2DB and Main2Set**: Opens another database and recordset for the AS400 system.
3. **Setting variables**: Sets various variables, including sheet width, length, and density.
4. **Looping through sheet sizes**: Loops through possible sheet widths and lengths, calculating total gross weight and updating records in Main2Set.
5. **Calculating sheet size**: Calls a subroutine (DoSheetSize) to calculate the gross weight for all parts at each sheet size.
The subroutine also updates several variables (`TotalGw`, `LSheetL`, `LSheetW`) and uses them to store results.
**DoSheetSize Subroutine**
This subroutine calculates the gross weight for all parts at a given sheet size. It:
* Moves to the first record in MainSet
* Calculates the total gross weight by summing up the weights of all records
* Updates the `TotalGw`, `LSheetL`, and `LSheetW` variables with the calculated values
The subroutine also updates the status label (`lblstatus`) to indicate that the calculation is in progress.
Reference in New Issue View Git Blame Copy Permalink