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
< VbzCart‎ | archive‎ | code‎ | VBA
Jump to navigation Jump to search 
' 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
Retrieved from "https://htyp.org/mw/index.php?title=VbzCart/archive/code/VBA/clsPackage&oldid=28616"