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

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