Cybernomad
/
PSLine2000Documentation
1
0
Fork 0
Code Issues 1 Pull Requests Packages Projects 1 Releases Wiki Activity
PSLine2000Documentation/Forms/SP Delete.md

1170 lines
34 KiB
Markdown
Raw Blame History

# SP Delete
Analysis generated on: 4/1/2025 4:06:48 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]] |
## VBA Code
```vba
Option Compare Database
Dim fromar(10), toar(10), curar(10), CurrSetSize(10), CurrSetGw(10), Sheets
Dim BestSS(10, 3, 6)
' |
' +---------------------> 0 - Sheet Size
' 1 - Price for sheet
' 2 - Pounds used
'
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 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!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
a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Pounds" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + 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) + ";"
If BestSS(SetNo, 2, 0) = 0 Then
ppp = 0
Else
ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0)
End If
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, 1, 0), "0"))
Next
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$(ttl# / ttlgw#, "###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:
TotalGw! = 0
TotalPrc! = 0
a1$ = ""
For SetNo = 1 To Sheets
a1$ = a1$ + Str$(curar(SetNo))
CurrSetSize(SetNo) = 0
CurrSetGw(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
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!
BestPrc! = Prc!
BestSet = SetNo
End If
If (BestSet = 0) And (Prc! <> 0) Then
BestWt! = Gw!
BestPrc! = Prc!
BestSet = SetNo
End If
End If
Next
If BestSet = 0 Then
goodset = False
Exit Do
Else
TotalGw! = BestWt! + TotalGw!
TotalPrc! = BestPrc! + TotalPrc!
CurrSetSize(BestSet) = CurrSetSize(BestSet) + BestPrc!
CurrSetGw(BestSet) = CurrSetGw(BestSet) + BestWt!
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!
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)
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)
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)
Next
BestSS(0, 1, worst2best + 1) = TotalPrc!
BestSS(0, 2, worst2best + 1) = TotalGw!
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)
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)
Next
BestSS(0, 1, worst2best) = TotalPrc!
BestSS(0, 2, worst2best) = TotalGw!
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)
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
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!
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 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
a3$ = ""
a2$ = Chr$(34) + "Width" + Chr$(34) + ";" + Chr$(34) + "Length" + Chr$(34) + ";" + Chr$(34) + " Price" + Chr$(34) + ";" + Chr$(34) + " Pounds" + Chr$(34) + ";" + Chr$(34) + " Price/Lb" + Chr$(34) + ";" + Chr$(34) + " Actual Wt" + 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) + ";"
If BestSS(SetNo, 2, 0) = 0 Then
ppp = 0
Else
ppp = BestSS(SetNo, 1, 0) / BestSS(SetNo, 2, 0)
End If
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"))
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$(ttl# / ttlgw#, "###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
```
## What it does
**Code Description**
This VBA code is written for Microsoft Access and appears to be part of a larger application for material utilization and inventory management. The code consists of two main subroutines: `BegLength_LostFocus`, `BegWidth_LostFocus`, and `CalcIters`.
### BegLength_LostFocus and BegWidth_LostFocus Subroutines
These two subroutines are event handlers that call the `CalcIters` subroutine when the corresponding form fields (Length or Width) lose focus. The purpose of these subroutines is to calculate iterations for material utilization based on the width and length changes.
The `CalcIters` subroutine calculates the total number of iterations (`Iterations`) by multiplying two numbers, `sz1` and `sz2`, which are calculated from the width and length changes. The result is then formatted into a string with zero decimal places.
### cmdButtnCalc_Click Subroutine
This subroutine is triggered when a button click event occurs. It performs the following tasks:
1. **Selecting Parts for Material Utilization**:
- Opens two databases (`MainDB` and `MainDB2`) and creates recordsets (`MainSet` and `MainSet2`) to access data.
- Runs a macro to select parts for material utilization.
- Deletes any existing records from the second database.
2. **Purging AS400 Product Number File**:
- Moves through the first database's recordset, deleting each record until all records are removed.
3. **Purging AS400 Result File**:
- Moves through the second database's recordset, adding new records with updated values from the first database's recordset.
4. **Activating AS400 Program**:
- Activates a program on an AS400 system.
5. **Retrieving Results**:
- Runs another macro to retrieve results from the AS400 system.
- Updates two report fields (`UtilResult1` and `Util Result1`) with the retrieved data.
### Command25_Click Subroutine
This subroutine is triggered when a button click event occurs. It appears to be part of a larger calculation for material utilization. The purpose of this subroutine is to calculate sheet sizes based on the width and length changes.
The subroutine performs the following tasks:
1. **Initializing Variables**:
- Sets various variables (`MainDB`, `MainSet`, `Main2DB`, `Main2Set`) to access data.
- Initializes variables for width, length, and density.
2. **Calculating Sheet Sizes**:
- Loops through a range of sheet widths and lengths based on the calculated changes.
- For each combination of width and length, calculates the total gross weight (`TotalGw!`).
- Adds new records to the second database with the calculated values.
3. **Updating Status Message**:
- Updates the status message label with a running tally of iterations for material utilization.
4. **Calculating Material Utilization Cost**:
- Calculates the cost of material utilization based on the total gross weight.
- Exits the subroutine if no density value is entered, or if the first iteration calculation has completed.
Reference in New Issue View Git Blame Copy Permalink