VbzCart/docs/archive/code/VBA/Form frmPackage
File:Vbzcart-MSAccess-frmPackage.png<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>