VbzCart/docs/archive/code/VBA/Form frmPackage

<VB> Option Compare Database Option Explicit Dim intID As Long Dim intPos As Long Dim qtyRtn As Long Public Sub UpdateData()

   Me.sfrmPackageItems.Requery
   UpdateCurrent True

End Sub Public Sub Locate(iID As Long)

   With Me.RecordsetClone
       .FindFirst "ID=" & iID
       If .NoMatch Then
           MsgBox "Package with ID=" & iID & " was not found in frmPackage.Locate().", vbCritical, "Internal Error"
       Else
           Me.Refresh
           DoCmd.GoToRecord , , acGoTo, .AbsolutePosition + 1
       End If
   End With

End Sub Private Property Get Package() As clsPackage

   Set Package = clsPackages.Item(intID)

End Property Private Sub UpdateCurrent(iForce As Boolean) ' ACTION: Updates buttons and other controls to reflect conditions in the current record

   Dim objShip As clsShipment
   Dim objPkg As clsPackage
   Dim idShip As Long
   Dim qtyShip As Long

   If iForce Or (intID <> Nz(Me.ID)) Then  ' avoid unnecessary repainting
       Me.Refresh
       If IsNull(Me.ID) Then
           Me.txtPkgCode = "NULL"
           Me.btnDoPack.Enabled = False
           Me.btnUnpack.Enabled = False
           Me.btnDelete.Enabled = False
           Me.cbxShipment.Enabled = False
       Else
           intID = Me.ID
           Set objPkg = clsPackages.Item(intID)
       
           ' show package code number:
           With objPkg
               Me.txtPkgCode = .Order.Code & "-" & .Seq
           End With
           
           ' get the shipment to which the package has been assigned
           Set objShip = objPkg.Shipment
           ' if no shipment has been assigned, assign package (tentatively) to the first open shipment
           If objShip Is Nothing Then
               idShip = 0
           Else
               idShip = objShip.ID
           End If
           If Me.cbxShipment <> idShip Then
               Me.ID_Shipment = objShip.ID
               Me.cbxShipment.Requery
               Me.chkShowClosedShip = Not objShip.IsOpen
           End If
           
           Me.btnRefresh.SetFocus
           If objPkg.IsPacked Then
           ' if package has been packed, just set enabled status of buttons
               Me.btnFetchStock.Enabled = False
               Me.btnDoPack.Enabled = False
               Me.btnDelete.Enabled = False
               If objShip Is Nothing Then
                   Me.cbxShipment.locked = False
               Else
                   Me.cbxShipment.locked = (Not objShip.IsOpen) And Not Me.chkShippedOverride
               End If
               If objShip Is Nothing Then
                   Me.btnUnpack.Enabled = True
               Else
                   If Me.chkShippedOverride Then
                       Me.btnUnpack.Enabled = True
                   Else
                       Me.btnUnpack.Enabled = objShip.IsOpen  ' can only remove from open shipment
                   End If
               End If
           Else
               With Me.sfrmPackageItems.Form.RecordsetClone
                   If .RecordCount > 0 Then
                       .MoveFirst
                       qtyRtn = 0
                       Do Until .EOF
                           If !QtyShipped > 0 Then
                               qtyShip = qtyShip + !QtyShipped
                           ElseIf !QtyShipped < 0 Then
                               qtyRtn = qtyRtn - !QtyShipped
                           End If
                           .MoveNext
                       Loop
                   End If
               End With
               Me.btnFetchStock.Enabled = True
               Me.btnDelete.Enabled = True
               Me.btnDoPack.Enabled = (qtyShip > 0)
               Me.btnReturnStock.Enabled = (qtyRtn > 0)
               Me.btnUnpack.Enabled = False
               Me.cbxShipment.locked = False
           End If
       End If
   End If

End Sub Private Sub UpdateShipments() ' ACTION: updates the list of shipments

   Dim strSrce As String
   If Me.chkShowClosedShip Then
       strSrce = "qryShipments_Summary_Closed"
   Else
       strSrce = "qryShipments_Summary_Open"
   End If
   If Me.cbxShipment.RowSource <> strSrce Then
       Me.cbxShipment.RowSource = strSrce
       Me.cbxShipment.Requery
   End If

End Sub Private Sub CheckKeyDn(iKeyCode As Integer, iShift As Integer)

   If iKeyCode = 13 Then
       intPos = Me.Form.CurrentRecord

' Me.Painting = False

   End If

End Sub Private Sub CheckKeyUp(iKeyCode As Integer, iShift As Integer)

   If iKeyCode = 13 Then
       If intPos <> Me.Form.CurrentRecord Then
           DoCmd.GoToRecord acDataForm, Me.Name, acGoTo, intPos
       End If

' Me.Painting = True

   End If

End Sub Private Sub btnDelete_Click()

   Dim objPkg As clsPackage
   Dim uResp As Integer

   Set objPkg = Package
   If Not (objPkg Is Nothing) Then
       uResp = MsgBox("Move packaged items back into stock?", vbQuestion Or vbYesNoCancel, "Keep Items?")
       If uResp = vbCancel Then Exit Sub
       objPkg.Delete (uResp = vbYes)
   End If
   DoCmd.Close acForm, Me.Name, acSavePrompt

End Sub Private Sub btnDoPack_Click()

   Dim objPkg As clsPackage
           
   UpdateCurrent False
   Me.Refresh  ' commit any data entry on the form back to the database
   
   If intID > 0 Then
       doCancel = False
       Set objPkg = Package
       objPkg.AddCharges Me.chkIncludeCharges
       UpdateCurrent True
       If doCancel Then
           MsgBox "The packing operation had insufficient data; please enter the data indicated and try again.", vbExclamation, "Incomplete Data"
       End If
   End If

End Sub Private Sub btnFetchStock_Click()

   Me.Refresh  ' commit any data entry on the form back to the database
   ' open up the stock puller
   With clsForms.StockPullerForm
       .Package_ID = Me.ID
       Set .Opener = Me
   End With

End Sub Private Sub btnNewShipment_Click()

   clsShipments.CreateAsk
   UpdateShipments
   UpdateCurrent True

End Sub Private Sub btnRefresh_Click()

   UpdateCurrent True

End Sub Private Sub btnReturnStock_Click() ' ASSUMES: If item is marked as cancelled but also shipped, customer may be returning item in this package. ' For each such item, asks user if it should be moved and allows choice of destination location.

   Dim strPrompt As String
   Dim idLoc As Long
   Dim objPkit As clsPackageItem
   Dim objItem As clsItem
   Dim qtyRtnItem As Long
   Dim frmLoc As Form_frmDlg_SelectLocation
   Dim doMove As Boolean

   With Me.sfrmPackageItems.Form.RecordsetClone
       .MoveFirst
       Set frmLoc = clsForms.Dlg_SelectLocation
       frmLoc.Location = LocForDeletedPkgs

       Do Until .EOF
           Set objPkit = New clsPackageItem
           objPkit.Init .Fields
           If objPkit.QtyOpen < 0 Then
               qtyRtnItem = -objPkit.QtyOpen
               
               Set objItem = objPkit.Item
               strPrompt = "Move " & qtyRtnItem & " of [" & objItem.CatNum & "] """ & objItem.Description & """ to this location:"
               doMove = frmLoc.doMove(strPrompt)
               If doMove Then
                   idLoc = frmLoc.Location
                   If idLoc = 0 Then Stop  ' bug
                   clsStockItems.AddFromPkgItem objPkit, idLoc
                   .Edit
                   !QtyShipped = -qtyRtnItem
                   .Update
               End If
           End If
           .MoveNext
       Loop
   End With

End Sub Private Sub btnUnpack_Click()

   Dim objPkg As clsPackage
   
   Set objPkg = Package
   If Not objPkg Is Nothing Then
       objPkg.DelCharges
   End If
   UpdateCurrent True

End Sub Private Sub cbxShipment_DblClick(Cancel As Integer)

   clsForms.ShipmentForm.LocateShipment Me.cbxShipment

End Sub Private Sub chkShippedOverride_Click()

   UpdateCurrent True

End Sub Private Sub chkShowClosedShip_Click()

   UpdateShipments

End Sub 'Private Sub editNotes_ToBuyer_KeyDown(KeyCode As Integer, Shift As Integer) ' CheckKeyDn KeyCode, Shift ' If KeyCode = 13 Then ' With Me.editNotes_ToBuyer ' .Value = .Text & vbCrLf ' End With ' Me.Refresh ' End If 'End Sub 'Private Sub editNotes_ToBuyer_KeyUp(KeyCode As Integer, Shift As Integer) ' CheckKeyUp KeyCode, Shift ' If KeyCode = 13 Then ' With Me.editNotes_ToBuyer ' UpdateCurrent True ' .SetFocus ' .SelStart = Len(.Text) + 1 ' .SelLength = 0 ' End With ' End If 'End Sub Private Sub Form_Current()

   UpdateCurrent False

End Sub Private Sub Form_Load() ' NOTE: when this event happens, OnCurrent also appears to be triggered soon afterwards; no need to repeat.

   UpdateShipments

End Sub Private Sub Form_Open(Cancel As Integer)

   Dim strArgs As xtString
   Dim strAct As String
   Dim strVal As String
   
   If Me.OpenArgs <> "" Then
       Set strArgs = New xtString
       strArgs.Value = " " & Me.OpenArgs
       strAct = strArgs.FindFirst
       strVal = strArgs.FindNext
       Select Case strAct
         Case "pkg"
           If IsNumeric(strVal) Then
               Me.Locate CLng(strVal)
           End If
       End Select
   End If

End Sub Private Sub Form_Resize()

   Dim glX As Single

   Me.Painting = False

   Me.Width = Me.InsideWidth
   With Me.editShipNotes
       glX = Me.InsideWidth - .Left
       If glX > 0 Then .Width = glX
   End With
   With Me.editWhenArrived
       glX = Me.InsideWidth - .Left
       If glX > 0 Then .Width = glX
   End With
   With Me.editArrivalNotes
       glX = Me.InsideWidth - .Left
       If glX > 0 Then .Width = glX
   End With
   With Me.tabMain
       .Width = Me.InsideWidth - .Left
       .Height = Me.InsideHeight - .Top
   End With
   With Me.sfrmPackageItems
       .Width = Me.pgItems.Width
       .Height = Me.pgItems.Height
   End With
   With Me.editNotes_ToBuyer
       .Left = Me.pgToBuyer.Left
       .Top = Me.pgToBuyer.Top
       .Width = Me.pgToBuyer.Width
       .Height = Me.pgToBuyer.Height
   End With
   With Me.editNotes_ToRecip
       .Width = Me.pgToRecip.Width
       .Height = Me.pgToRecip.Height
   End With
   With Me.editNotes_Internal
       .Width = Me.pgInternal.Width
       .Height = Me.pgInternal.Height
   End With
   
   Me.Painting = True

End Sub </VB>