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

18 KiB
Raw Permalink Blame History

xyz

Record Source

  • None

Controls

Control Name Reference
List86 (Row Source)

VBA Code

Option Compare Database
   Dim fromar(10), toar(10), curar(10), CurrSetSize(10), Sheets
   Dim BestSS(10, 3, 6)
'                 |
'                 +---------------------> 0 - Sheet Size
'                                         1 - Pounds used
'                                         2 - Price for sheet
'


Private Sub ActiveXCtl24_Click()
End Sub

Private Sub ActiveXCtl24_CommandComplete(ByVal returnValue As Long)
End Sub

Private Sub ActiveXCtl24_Updated(code As Integer)

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 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.
   
   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
   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

'
'  Count up the number of iterations to go through
'
   NoOfIters% = 0
   lblstatus.Caption = "Numbering Iterations"
   Main2Set.MoveFirst
   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
   Loop
   
   If NoOfIters% < Sheets Then
      MsgBox ("Not Enough Iterations")
      Command79.Enabled = True
      Exit Sub
   End If
   Iterations = NoOfIters%
   
   GoSub Init_Iterations
   FirstIter = True
          
   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
          
   GoSub CalcGWforSet
   


   CurrentSheetSet = ""
   a1$ = ""
   a2$ = ""
   ttl# = 0
   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) + ";"
      ttl# = ttl# + 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)
   BestSheetSet = a1$
   List86.rowSource = a2$

   Command79.Enabled = True

Exit Sub

CalcGWforSet:
   TotalGw! = 0
         
   a1$ = ""
   For SetNo = 1 To Sheets
      a1$ = a1$ + Str$(curar(SetNo))
      CurrSetSize(SetNo) = 0
   Next
   CurrentSheetSet = a1$
   MainSet.MoveFirst
   Do
      If Not (MainSet.EOF) Then
         
         BestWt! = 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)
            If SetNo = 1 Then
               BestWt! = Gw!
               BestSet = SetNo
            Else
               If BestWt! > Gw! Then
                  BestWt! = Gw!
                  BestSet = SetNo
               End If
            End If
         Next
         TotalGw! = BestWt! + TotalGw!
         CurrSetSize(BestSet) = CurrSetSize(BestSet) + BestWt!
      
         DoEvents
      Else
         DoEvents
         Exit Do
      End If
      MainSet.MoveNext
   Loop
      
   If (TotalGw! < bestsetgw!) Or FirstIter Then
      FirstIter = False
      bestsetgw! = TotalGw!
      LGrossWt = TotalGw!
      BestSheetSet = CurrentSheetSet
      For SetNo = 1 To Sheets
         BestSS(SetNo, 0, 0) = curar(SetNo)
         BestSS(SetNo, 1, 0) = CurrSetSize(SetNo)
         For top6 = 6 To 1 Step -1
            BestSS(SetNo, 0, top6) = BestSS(SetNo, 0, top6 - 1)
            BestSS(SetNo, 1, top6) = BestSS(SetNo, 1, top6 - 1)
         Next
      Next
   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

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
   
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
   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) + ";"
      ttl# = ttl# + Val(Format(BestSS(SetNo, 1, A), "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)
   List86.rowSource = a2$
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

What it does

ActiveX Control 24 Calculation and Material Utilization Code

This VBA code is used to calculate material utilization for a set of parts in an Excel worksheet. It consists of several subroutines that perform the following tasks:

Initialization and Event Handling

The code initializes variables and sets up event handlers for buttons and macros.

  • ActiveXCtl24_Click(): Empty subroutine for handling button clicks.
  • ActiveXCtl24_CommandComplete() and ActiveXCtl24_Updated(code As Integer): Empty subroutines for handling command completion and updates.
  • BegLength_LostFocus() and BegWidth_LostFocus(): Subroutines called when the length and width fields lose focus, which calls CalcIters() to update calculations.

Calculation of Sheet Size and Material Utilization

The code uses several variables to store sheet size values:

  • sz1 and sz2: Calculated values for sheet size based on width and length changes.
  • Iterations: Stores the number of iterations performed during calculations, formatted as a string (e.g., "123").

The CalcIters() subroutine calculates these values based on input field changes:

Private Sub CalcIters()
    sz1 = Abs(EndWidth - BegWidth)
    If IncWidth \u003c\u003e 0 Then
        sz1 = sz1 / Abs(IncWidth)
    End If
    sz1 = sz1 + 1
    sz2 = Abs(EndLength - BegLength)
    If IncLength \u003c\u003e 0 Then
        sz2 = sz2 / Abs(IncLength)
    End If
    sz2 = sz2 + 1
    sz1 = sz1 * sz2
    Iterations = Format$(sz1, "0")

Material Utilization Calculation and Macro Execution

The cmdButtnCalc_Click() subroutine performs the following steps:

  • Retrieves data from two databases (MainDB and MainDB2) using dynamic recordsets.
  • Purges existing records in the first database.
  • Adds new records to the second database, including parts with calculated material utilization values.
  • Activates an AS400 program using the ActiveXCtl24.DoClick() method.
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)
    
    ' ... (parsing and modifying records in MainDB and MainDB2 databases) ...
    
    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 = "Done"

Material Matrix Calculation and Display

The Command25_Click() subroutine:

  • Retrieves data from two databases (MainDB and Main2DB) using dynamic recordsets.
  • Iterates over sheet size values, adding new records to the second database with calculated material utilization values.
Private Sub Command25_Click()
    ' ... (parsing and modifying records in MainDB and Main2DB databases) ...
    
    Dim TotalGw! As Double
    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 \u003e TotalGw!) Then
                LGrossWt = TotalGw!
                LSheetL = SheetLength
                LSheetW = SheetWidth
                First = False
            End If
        Next
    Next
    
    Cost = 0
End Sub

DoSheetSize:
    ' ... (calculate material utilization values based on current sheet size) ...