VbzCart/docs/archive/code/VBA/clsPackageItems

syntaxhighlight lang=<VB> ' CLASS: clsPackages

Option Compare Database Option Explicit

Private rs As Recordset Private intAccessCount As Long Public Sub Init()

   intAccessCount = 0
   Set rs = Nothing

End Sub Public Property Get Data() As Recordset

   Set Data = rs

End Property Public Property Get Data_Items() As Recordset ' Set Data_Items = CurrentDb.OpenRecordset("qryPkgItems_Items", dbOpenSnapshot)

   Set Data_Items = CurrentDb.OpenRecordset("Package Items", dbOpenSnapshot)

End Property Public Sub DataOpen()

   If intAccessCount = 0 Then
       Set rs = CurrentDb.OpenRecordset("Package Items", dbOpenDynaset)
   End If
   intAccessCount = intAccessCount + 1

End Sub Public Sub DataShut()

   intAccessCount = intAccessCount - 1
   If intAccessCount = 0 Then
       rs.Close
       Set rs = Nothing
   End If

End Sub Public Property Get Item(iID As Long) As clsPackageItem

   Dim objItem As clsPackageItem

   Me.DataOpen
   With Me.Data
       .FindFirst "ID=" & iID
       If .NoMatch Then

' MsgBox "Package ID " & iID & " not found", vbCritical, "Internal Error"

           Set objItem = Nothing
       Else
           Set objItem = New clsPackageItem
           objItem.Init .Fields
       End If
   End With
   Me.DataShut
   Set Item = objItem

End Property Public Property Get Packings(iOrderItem As Long) As Scripting.Dictionary ' ACTION: returns a list of all packings of the given order item

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

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

End Property 'Public Function Create(iOrder As Long) As clsPackage ACTION: create a new package record/object ' Dim objNew As clsPackage ' Dim intCode As Long ' Dim strFilt As String ' ' Set objNew = New clsPackage ' Me.DataOpen ' With Me.Data ' ' find the highest used package code ' strFilt = "ID_Order=" & iOrder ' .FindFirst strFilt ' Do Until .NoMatch ' If intCode < !Seq Then ' intCode = !Seq ' End If ' .FindNext strFilt ' Loop ' intCode = intCode + 1 ' then increment it by one ' ' ' now create the new record ' .AddNew ' !ID_Order = iOrder ' !Code = intCode ' !WhenStarted = Now ' .Update ' objNew.Init .Fields ' End With ' Me.DataShut ' Set Create = objNew 'End Function </syntaxhighlight>