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

1366 lines
40 KiB
Markdown
Raw Blame History

# Utilization on Multiple Sheets old
Analysis generated on: 4/1/2025 4:02:00 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 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
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
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 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
```
## What it does
**Detailed Description of VBA Code**
### Overview
The provided VBA code is part of an Excel workbook and appears to be a macro script that automates tasks related to material utilization, specifically for calculating material costs based on sheet sizes. The code consists of several subroutines, each with its own specific purpose.
### Subroutine Descriptions
#### `ActiveXCtl24_Click` and `ActiveXCtl24_CommandComplete`
These two subroutines are empty and do not perform any actions when clicked or completed. They seem to be placeholders for future functionality.
#### `BegLength_LostFocus` and `BegWidth_LostFocus`
These subroutines call the `CalcIters` procedure when the user loses focus on a text field containing "Beg" (short for "Beginning") values. The purpose of these subroutines is unclear, but they seem to be related to calculations involving the lengths and widths of sheets.
#### `CalcIters`
This subroutine performs calculations based on the beginning length and width of a sheet, as well as any incremental changes. It calculates:
* `sz1`: the total iterations (i.e., the number of steps) for a given length
* `sz2`: the total iterations for a given width
* The product of `sz1` and `sz2`
* Formats this product as a zero-padded string
The purpose of these calculations is unclear without more context.
#### `cmdButtnCalc_Click`
This subroutine initiates the main calculation process when a button labeled "Calculate" is clicked. It performs the following steps:
* Opens two databases (`MainDB` and `MainDB2`) using the Excel engine
* Creates dynamic recordsets from these databases to manipulate material utilization data
* Purges old product number files on both databases
* Iterates over a range of sheet sizes, calculating material costs for each size
* Updates the records in the second database with calculated values and totals
* Activates an AS400 program (presumably a remote access or automation system)
* Retrieves results from the AS400 program using another macro
* Formats the final output
The purpose of this subroutine appears to be to automate the material utilization calculation process, including data retrieval and processing.
#### `Command25_Click`
This subroutine is similar to `cmdButtnCalc_Click`, but it seems to be a smaller, modified version. It:
* Opens two databases (`MainDB` and `MainDB2`) using the Excel engine
* Creates dynamic recordsets from these databases to manipulate material utilization data
* Sets up variables for sheet widths and lengths based on input values
* Iterates over a range of sheet sizes, performing calculations and updating records in the second database
The purpose of this subroutine appears to be similar to `cmdButtnCalc_Click`, but with some key differences.
### Unclear Aspects
Some aspects of the code are unclear or require additional context to understand their purpose:
* The `BegLength_LostFocus` and `BegWidth_LostFocus` subroutines seem to be related to calculations involving sheet lengths and widths, but their exact purpose is unclear.
* The `CalcIters` subroutine performs calculations based on length and width values, but its specific purpose or the context in which it's used are unclear.
### Recommendations
To improve clarity and understandability of this code:
* Add comments to explain the purpose of each subroutine and calculate
* Consider refactoring the code to make it more modular and easier to maintain
* Provide additional context for unknown or unclear aspects of the code
Reference in New Issue View Git Blame Copy Permalink