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

1293 lines
38 KiB
Markdown
Raw Blame History

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