VbzCart/archive/code/VBA/clsPackage

from HTYP, the free directory anyone can edit if they can prove to me that they're not a spambot
Jump to navigation Jump to search

<VB> ' CLASS: clsPackage

Option Compare Database Option Explicit

Private vID As Long Private vSeq As Long Private vOrder As Long Private vShpmt As Long Private vWhenStarted As Variant Private vWhenFinished As Variant Private vNotes_StoreToBuyer As String Private vNotes_StoreToRecip As String Private vNotes_Internal As String 'Private vAddr As String Private vWhenChecked As Variant Public Sub Init(iFields As Fields) 

   With iFields
       vID = !ID
       vSeq = !Seq
       vOrder = !ID_Order
       vShpmt = Nz(!ID_Shipment)
       vWhenStarted = !WhenStarted
       vWhenFinished = !WhenFinished
       vNotes_StoreToBuyer = Nz(!Notes_StoreToBuyer)
       vNotes_StoreToRecip = Nz(!Notes_StoreToRecip)
       vNotes_Internal = Nz(!Notes_Internal)
       vWhenChecked = !WhenChecked
   End With

End Sub Public Sub Save() ' ACTION: save the object's data back to the database 

   With clsPackages
       .DataOpen
       If Located Then
           With .Data
               .Edit
               !Seq = vSeq
               !ID_Order = vOrder
               !ID_Shipment = IIf(vShpmt = 0, Null, vShpmt)
               !WhenStarted = vWhenStarted
               !WhenFinished = vWhenFinished
               !WhenChecked = vWhenChecked
               .Update
           End With
       End If
       .DataShut
   End With

End Sub Public Property Get ID() As Long 

   ID = vID

End Property Public Property Get Seq() As Long 

   Seq = vSeq

End Property Public Property Get Code() As String 

   Code = Me.Order.Code & "-" & Me.Seq

End Property Public Property Get Order_ID() As Long 

   Order_ID = vOrder

End Property Public Property Get Order() As clsOrder 

   Set Order = clsOrders.Item(vOrder)

End Property Public Property Get IsPacked() As Boolean ' ACTION: Returns TRUE iff the package has been finished (and placed into a shipment). 

   IsPacked = Not IsNull(vWhenFinished)

End Property Public Sub AddCharges(iIncludeShipping As Boolean) ' ACTION: create charge transactions for this package ' 1. 2002-08-24 THIS STEP IS NOT NEEDED: create a shipment if there isn't one assigned ' 2. for each item in the package, increment the qtyDone for the corresponding order item ' 3. create a transaction entry for this package in the order's transactions (ITEM) ' 4. set the package's "finished" timestamp (do this last) ' Dim objShip As clsShipment 

   Dim objItem As clsPackageItem
   Dim objList As Scripting.Dictionary
   Dim objTrx As clsTrxactn
   Dim curTotal As Currency
   Dim curShItm As Currency
   Dim curShPkg As Currency
   Dim curShPkgMax As Currency
   
   DBEngine.BeginTrans

STEP 1 - get/create shipment object/record ' If Me.ShipmentExists Then ' Set objShip = Me.Shipment ' Else ' If MsgBox("No shipment has been assigned. Ok to create a new one?", vbOKCancel, "Confirm") = vbOK Then ' Set objShip = objShipments.Create ' vShpmt = objShip.ID ' Else ' DBEngine.Rollback ' Exit Sub ' End If ' End If

' STEP 2 - increment order item's qtyDone & add the costs 

   Set objList = Me.Items
   For Each objItem In objList
       With objItem
           If .QtyShipped <> 0 Then    ' negative = returned items
               .Ship
               curTotal = curTotal + .PriceTotal
               curShItm = curShItm + .ShipItemTotal
               curShPkg = .ShipPkgEffective
               GoSub CheckCancel
           End If
       End With
       If curShPkg > curShPkgMax Then curShPkgMax = curShPkg
   Next objItem

' STEP 3 - create transaction(s) 

   Set objTrx = New clsTrxactn
   With objTrx
       .Descr = "total for items being shipped"
       .Type_ID = kiTrxType_ItemShipped
       .Order_ID = Me.Order_ID
       .Package_ID = Me.ID
       .Amount = curTotal
       .SaveNew
       If iIncludeShipping Then
       ' create transactions for shipping charges
       ' - itemized shipping total
           .Descr = "itemized shipping total"
           .Type_ID = kiTrxType_ShippingItemized
           .Amount = curShItm
           .SaveNew
       ' - package charge
           .Descr = "shipping package"
           .Type_ID = kiTrxType_ShippingPackage
           .Amount = curShPkgMax
           .SaveNew
       End If
   End With
   GoSub CheckCancel

' STEP 4 - package's "finished" timestamp 

   vWhenFinished = Now

' CLEANUP 

   Me.Save
   DBEngine.CommitTrans
   Exit Sub

CheckCancel: 

   If doCancel Then
       DBEngine.Rollback
       Exit Sub
   End If
   Return

End Sub 'Public Function StockIsPulled() As Boolean ACTION: checks to see if at least one line item has been pulled from stock 'End Function Public Function FindItem(iItem As Long, iStartPkgItem As Long) As clsPackageItem ' ACTION: Returns the package item object for the given item; Nothing if not found. ' iStart is the ID of the package-item to start from (i.e. skip) 

   Dim sqlFilt As String
   Dim objItem As clsPackageItem
   Dim rs As Recordset

   Set rs = clsPackageItems.Data_Items
   With rs
       sqlFilt = "(ID_Package=" & Me.ID & ") AND (ID_Item=" & iItem & ")"
       If iStartPkgItem = 0 Then
           .FindFirst sqlFilt
       Else
           .FindFirst "ID=" & iStartPkgItem
           .FindNext sqlFilt
       End If
       If .NoMatch Then
           Set objItem = Nothing
       Else
       ' there should be only one entry per package for each item, so the first one is it.
           Set objItem = New clsPackageItem
           objItem.Init .Fields
       End If
   End With
   Set FindItem = objItem

End Function Public Sub PullItem(iStockItem As Long, iQty As Long) ' ACTION: removes the given quantity of the given item from stock and adds it to the package ' NOTE: Only use this method when there is no specific package line. 

   Dim objLine As clsStockItem

   Set objLine = clsStockItems.Item(iStockItem)
   objLine.FetchToPkgLine iQty, Me.ID

End Sub Public Sub DelCharges() ' ACTION: remove the charge transactions for this package ' 1. (ok to leave shipment assigned; no action needed) ' 2. for each item in the package, DECrement the qtyDone for the corresponding order item ' 3. REMOVE the transaction entry for this package in the order's transactions (ITEM) ' 4. CLEAR the package's "finished" timestamp 

   Dim objItem As clsPackageItem
   Dim objList As Scripting.Dictionary
   Dim objTrx As clsTrxactn
   Dim ok As Boolean
   Dim sqlFilt As String
   
   DBEngine.BeginTrans

' STEP 2 - DECrement order item's qtyDone 

   Set objList = Me.Items
   For Each objItem In objList
       objItem.UnShip
   Next objItem

' STEP 3 - DELETE transactions 

   sqlFilt = "ID_Package=" & Me.ID
   With clsTrxactns
       .DataOpen
       With .Data
           .FindFirst sqlFilt
           Do Until .NoMatch
               .Delete
               .FindNext sqlFilt
           Loop
       End With
       .DataShut
   End With

' STEP 4 - CLEAR package's "finished" timestamp 

   vWhenFinished = Null

' CLEANUP 

   Me.Save
   DBEngine.CommitTrans

End Sub Public Property Get Shipment_ID() As Long 

   Shipment_ID = vShpmt

End Property Public Property Get Shipment() As clsShipment 

   If vShpmt = 0 Then
       Set Shipment = Nothing
   Else
       Set Shipment = clsShipments.Item(vShpmt)
   End If

End Property Public Property Get ShipmentExists() As Boolean 

   ShipmentExists = (vShpmt <> 0)

End Property Public Property Get WhenStarted() As Date 

   WhenStarted = vWhenStarted

End Property Public Property Get WhenFinished() As Date 

   WhenFinished = vWhenFinished

End Property Public Property Get HasBeenFinished() As Boolean 

   HasBeenFinished = Not IsNull(vWhenFinished)

End Property Public Property Get Checked() As Boolean 

   Checked = Not IsNull(vWhenChecked)

End Property Public Property Let Checked(iDone As Boolean) 

   If iDone <> Me.Checked Then
       If iDone Then
           vWhenChecked = Now
       Else
           vWhenChecked = Null
       End If
       Save
   End If

End Property Public Property Get Items() As Scripting.Dictionary ' ACTION: returns a list of objects, one for each Package Item in the current Package 

   Dim strFilt As String
   Dim objList As Scripting.Dictionary
   Dim objItem As clsPackageItem

   strFilt = "ID_Package=" & Me.ID
   Set objList = New Scripting.Dictionary
   With clsPackageItems
       .DataOpen
       With .Data
           .FindFirst strFilt
           Do Until .NoMatch
               Set objItem = New clsPackageItem
               objItem.Init .Fields
               objList.Add objItem, objItem.ID
               .FindNext strFilt
           Loop
       End With
       .DataShut
   End With
   Set Items = objList

End Property Public Property Get QtyShipped() 

   Dim objItem As clsPackageItem
   Dim qtyShp As Long
   
   For Each objItem In Me.Items
       qtyShp = qtyShp + objItem.QtyShipped
   Next objItem
   QtyShipped = qtyShp

End Property Public Property Get Messages(iMedia As Long, iPrefix As String) As String 

   Dim sqlFilt As String
   Dim strOut As String

   sqlFilt = "(ID_Media=" & iMedia & ") AND ((ID_Package=" & Me.ID & ") OR ((ID_Order =" & Me.Order_ID & ") AND (ID_Package IS NULL)))"
   With clsOrderMsgs
       .DataOpen
       With .Data
           .FindFirst sqlFilt
           Do Until .NoMatch
               If Not IsNull(!Message) Then
                   If strOut <> "" Then
                       strOut = strOut & vbCrLf
                   End If
                   strOut = strOut & iPrefix & !Message
               End If
               .FindNext sqlFilt
           Loop
       End With
       .DataShut
   End With
   Messages = strOut

End Property Public Property Get NotesSummary(iBuyer As Boolean, iRecip As Boolean, iStore As Boolean) As String ' ACTION: returns a string containing all notes intended for the given targets, as indicated ' NOTE: It is assumed that if only one note-set is flagged on, then no header "-- Message from..." should be included. ' NOTE ALSO: This method of tracking messages is deprecated, and will be replaced eventually. 

   Dim strNotes As String
   Dim isPlural As Boolean
   
   isPlural = (CLng(iBuyer) + CLng(iRecip) + CLng(iStore) < -1)

   With Me.Order
       If iRecip Then AppendNote strNotes, .Notes_BuyerToRecip, "-- Message from customer to recipient:", isPlural
       If iStore Or iBuyer Then
           AppendNote strNotes, .Notes_BuyerToStore, "-- Message from customer to us:", isPlural
       End If
       If iStore Then
           AppendNote strNotes, .Notes_Internal, "-- Message to ourselves (for this order):", isPlural
       End If
   End With
   If iBuyer Then AppendNote strNotes, vNotes_StoreToBuyer, "-- Message from us to the customer:", isPlural
   If iRecip Then AppendNote strNotes, vNotes_StoreToRecip, "-- Message from us to the recipient:", isPlural
   If iStore Then AppendNote strNotes, vNotes_Internal, "-- Message to ourselves (for this package):", isPlural
   NotesSummary = strNotes

End Property Private Sub AppendNote(ioConcat As String, iNote As String, iDescr As String, Optional iUseDescr As Boolean = True) 

   If iNote <> "" Then
       If ioConcat <> "" Then ioConcat = ioConcat & vbCrLf & vbCrLf
       If iUseDescr Then
           ioConcat = ioConcat & iDescr & vbCrLf
       End If
       ioConcat = ioConcat & iNote
   End If

End Sub Public Sub Delete(iMoveToStock As Boolean) ' ACTIONS: ' - move all this package's items to the location set by policy (if any) ' - delete the package record and all its item records 

   Dim strFilt As String
   Dim idLoc As Long
   Dim uResp As Integer
   Dim rs As Recordset
   Dim objItem As clsPackageItem

' Dim objOrdItm As clsOrderItem 

   idLoc = LocForDeletedPkgs
   If idLoc = 0 Then
       If iMoveToStock Then
           uResp = MsgBox("No location for deleted package items has been set. Delete anyway?", vbQuestion Or vbOKCancel, "Are you sure?")
           If uResp = vbCancel Then Exit Sub
       End If
   End If

' 1. Delete package items 

   strFilt = "ID_Package=" & Me.ID
   With clsPackageItems
       Set rs = .Data_Items
       rs.FindLast strFilt
       Do Until rs.NoMatch
           Set objItem = .Item(rs!ID)
           If iMoveToStock And (idLoc <> 0) And (Nz(rs!QtyShipped) <> 0) Then
               If objItem Is Nothing Then
                   uResp = MsgBox("Could not find package item ID=" & !ID, vbExclamation, "Record not found")
                   Exit Sub
               End If
               ' move the item to stock
   '                Set objOrdItm = clsOrderItems.Item(rs!ID_OrderItem)
   '                clsStockItems.Add idLoc, rs!QtyShipped, rs!ID_Item, objOrdItm.ID
               clsStockItems.AddFromPkgItem objItem, idLoc
           End If
           ' delete the item record from the package
           If objItem Is Nothing Then
               uResp = MsgBox("Package line " & Me.Seq & " has no item set. Deleting package item record anyway.", vbExclamation Or vbOKCancel, "Item not found")
               If uResp = vbCancel Then Exit Sub
           Else
               If Not objItem.Delete Then
                   uResp = MsgBox("Could not delete package item ID=" & !ID, vbExclamation Or vbOKCancel, "Record not found")
                   If uResp = vbCancel Then Exit Sub
               End If
           End If
           ' move to the next item
           rs.FindPrevious strFilt
       Loop
   End With

' 2. Delete the package 

   With clsPackages
       .DataOpen
       If Located Then
           With .Data
               .Delete
           End With
       End If
       .DataShut
   End With

End Sub Public Sub Edit() ' ACTION: opens the form for editing a package, and loads the current package record into it 

   Dim frmPkg As Form_frmPackage

   Set frmPkg = clsForms.PackageForm_GotoPkg(Me.ID)

' clsForms.PackageForm.Locate Me.ID End Sub Private Function Located() As Boolean 

   With clsPackages.Data
       If !ID <> Me.ID Then
           .FindFirst "ID=" & Me.ID
           Located = Not .NoMatch
       Else
           Located = True
       End If
   End With

End Function </VB>

Retrieved from "https://htyp.org/mw/index.php?title=VbzCart/archive/code/VBA/clsPackage&oldid=20366"