VbzCart/docs/archive/code/VBA/Form frmPackage
Jump to navigation
Jump to search
File:Vbzcart-MSAccess-frmPackage-running.pngFile:Vbzcart-MSAccess-frmPackage.png
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