Woozle at 12:45, 14 October 2022

2022-10-14T12:45:57Z

← Older revision		Revision as of 12:45, 14 October 2022
Line 1:		Line 1:
	<VB>		<syntaxhighlight lang=VB>
	' CLASS: clsPackage		' CLASS: clsPackage

Line 432:		Line 432:
	End With		End With
	End Function		End Function
	</VB>		</syntaxhighlight>

Woozle: Woozle moved page VbzCart/code/VBA/clsPackage to VbzCart/archive/code/VBA/clsPackage

2014-12-19T02:08:57Z

Woozle moved page VbzCart/code/VBA/clsPackage to VbzCart/archive/code/VBA/clsPackage

← Older revision	Revision as of 02:08, 19 December 2014
(No difference)

Woozle: Created page with " ' 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 ..."

2014-05-08T00:45:55Z

Created page with "<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 ..."

New page

<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>

VbzCart/archive/code/VBA/clsPackage - Revision history

Woozle at 12:45, 14 October 2022

Woozle: Woozle moved page VbzCart/code/VBA/clsPackage to VbzCart/archive/code/VBA/clsPackage

Woozle: Created page with " ' 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 ..."