Appendix: Complete Code Listings
Listing 1
/****** Object: Table [dbo].[Accounts] Script Date: 5/5/99 3:46:19 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[Accounts]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[Accounts]
GO
CREATE TABLE [dbo].[Accounts] (
[IDPK] [int] NOT NULL ,
[FirstName] [varchar] (20) NOT NULL ,
[LastName] [varchar] (40) NOT NULL ,
[AddressLine1] [varchar] (20) NOT NULL ,
[AddressLine2] [varchar] (20) NOT NULL ,
[City] [varchar] (20) NOT NULL ,
[State] [varchar] (2) NOT NULL ,
[Zip] [varchar] (5) NOT NULL ,
[Phone] [varchar] (12) NOT NULL ,
[Email] [varchar] (20) NOT NULL ,
[Balance] [money] NOT NULL ,
[Limit] [money] NOT NULL ,
CONSTRAINT [PK_Accounts] PRIMARY KEY NONCLUSTERED
(
[IDPK]
) ON [PRIMARY]
) ON [PRIMARY]
GO
Listing 2
/****** Object: Table [dbo].[Inventory] Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[Inventory]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[Inventory]
GO
CREATE TABLE [dbo].[Inventory] (
[IDPK] [int] NOT NULL ,
[Description] [varchar] (50) NOT NULL ,
[Price] [money] NOT NULL ,
[QOH] [int] NOT NULL ,
CONSTRAINT [PK_Inventory] PRIMARY KEY NONCLUSTERED
(
[IDPK]
) ON [PRIMARY]
) ON [PRIMARY]
GO
Listing 3
/****** Object: Table [dbo].[PurchaseOrders] Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[PurchaseOrders]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[PurchaseOrders]
GO
CREATE TABLE [dbo].[PurchaseOrders] (
[IDPK] [int] NOT NULL ,
[AccountIDFK] [int] NOT NULL ,
[OrderDate] [datetime] NULL CONSTRAINT [DF_PurchaseOrders_OrderDate] DEFAULT (getdate()),
[ShippingHandling] [money] NOT NULL ,
[TaxRate] [real] NOT NULL ,
[Total] [money] NOT NULL ,
[ShipToFirstName] [varchar] (20) NOT NULL ,
[ShipToLastName] [varchar] (40) NOT NULL ,
[ShipToAddressLine1] [varchar] (20) NOT NULL ,
[ShipToAddressLine2] [varchar] (20) NOT NULL ,
[ShipToCity] [varchar] (20) NOT NULL ,
[ShipToState] [varchar] (2) NOT NULL ,
[ShipToZip] [varchar] (5) NOT NULL ,
[ShipToPhone] [varchar] (12) NOT NULL ,
[ShipToEmail] [varchar] (20) NOT NULL ,
CONSTRAINT [PK_PurchaseOrders] PRIMARY KEY NONCLUSTERED
(
[IDPK]
) ON [PRIMARY] ,
CONSTRAINT [FK_PurchaseOrders_Accounts] FOREIGN KEY
(
[AccountIDFK]
) REFERENCES [dbo].[Accounts] (
[IDPK]
)
) ON [PRIMARY]
GO
Listing 4
/****** Object: Table [dbo].[LineItems] Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[LineItems]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[LineItems]
GO
CREATE TABLE [dbo].[LineItems] (
[IDPK] [int] NOT NULL ,
[PurchaseOrderIDFK] [int] NOT NULL ,
[InventoryIDFK] [int] NOT NULL ,
[Price] [money] NOT NULL ,
[Quantity] [int] NOT NULL ,
CONSTRAINT [PK_LineItems] PRIMARY KEY NONCLUSTERED
(
[IDPK]
) ON [PRIMARY] ,
CONSTRAINT [FK_LineItems_Inventory] FOREIGN KEY
(
[InventoryIDFK]
) REFERENCES [dbo].[Inventory] (
[IDPK]
),
CONSTRAINT [FK_LineItems_PurchaseOrders] FOREIGN KEY
(
[PurchaseOrderIDFK]
) REFERENCES [dbo].[PurchaseOrders] (
[IDPK]
)
) ON [PRIMARY]
GO
Listing 5
/****** Object: Table [dbo].[UniqueIDs] Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[UniqueIDs]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)
drop table [dbo].[UniqueIDs]
GO
CREATE TABLE [dbo].[UniqueIDs] (
[StartingIDofCurrentBatch] [int] NOT NULL ,
CONSTRAINT [PK_AccountUniqueIDs] PRIMARY KEY NONCLUSTERED
(
[StartingIDofCurrentBatch]
) ON [PRIMARY]
) ON [PRIMARY]
GO
Listing 6
' IAccount
Option Explicit
Public ID As Long
Public FirstName As String
Public LastName As String
Public AddressLine1 As String
Public AddressLine2 As String
Public City As String
Public State As String
Public Zip As String
Public Phone As String
Public Email As String
Public Balance As Currency
Public Limit As Currency
Public Function MarshalToPropertyBag(strKey As String) As Byte()
End Function
Public Property Get Valid() As Boolean
End Property
Listing 7
' IAccountExec
Option Explicit
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As Recordset
End Function
Public Function Create(rIAccount As IAccount, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function Destroy(ByVal lngAccountID As Long) As Boolean
End Function
Public Function Modify(rIAccount As IAccount, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function IncrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
End Function
Public Function DecrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
End Function
Listing 8
' IInventory
Option Explicit
Public ID As Long
Public Description As String
Public Price As Currency
Public QOH As Long
Public Function MarshalToPropertyBag(strKey As String) As Byte()
End Function
Public Property Get Valid() As Boolean
End Property
Listing 9
' IInventoryExec
Option Explicit
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As Recordset
End Function
Public Function Create(rIInventory As IInventory, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function Destroy(ByVal lngInventoryID As Long) As Boolean
End Function
Public Function IncrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
End Function
Public Function DecrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
End Function
Public Function Modify(rIInventory As IInventory, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Listing 10
' ILineItem
Option Explicit
Public ID As Long
Public PurchaseOrderID As Long
Public Item As IInventory
Public Price As Currency
Public Quantity As Long
Public Function MarshalToPropertyBag(strKey As String) As Byte()
End Function
Public Property Get Valid() As Boolean
End Property
Listing 11
' ILineItemExec
Option Explicit
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As Recordset
End Function
Public Function Create(rILineItem As ILineItem, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function Destroy(ByVal lngLineItemID As Long) As Boolean
End Function
Public Function DestroyByPurchaseOrder(ByVal lngPurchaseOrderID As Long) As Boolean
End Function
Public Function Modify(rILineItem As ILineItem, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Listing 12
' ILineItems
Option Explicit
Public Function Add(rILineItem As ILineItem) As Boolean
End Function
Public Property Get Count() As Long
End Property
Public Function Item(ByVal lngPosKey As Long) As ILineItem
End Function
Public Function Remove(ByVal lngPosKey As Long) As Boolean
End Function
Listing 13
' IPurchaseOrder
Option Explicit
Public ID As Long
Public AccountID As Long
Public OrderDate As Date
Public SubTotal As Currency
Public ShippingHandling As Currency
Public TaxRate As Double
Public Tax As Currency
Public Total As Currency
Public ShipToFirstName As String
Public ShipToLastName As String
Public ShipToAddressLine1 As String
Public ShipToAddressLine2 As String
Public ShipToCity As String
Public ShipToState As String
Public ShipToZip As String
Public ShipToPhone As String
Public ShipToEmail As String
Public Property Get Valid() As Boolean
End Property
Public Function MarshalToPropertyBag(strKey As String) As Byte()
End Function
Public Property Get LineItems() As ILineItems
End Property
Listing 14
' IPurchaseOrderExec
Option Explicit
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As Recordset
End Function
Public Function Create(rIPurchaseOrder As IPurchaseOrder, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function Destroy(ByVal lngPurchaseOrderID As Long) As Boolean
End Function
Public Function Modify(rIPurchaseOrder As IPurchaseOrder, Optional ByVal blnByVal As Boolean = True) As Boolean
End Function
Public Function Cancel(ByVal lngPurchaseOrderID As Long) As Boolean
End Function
Listing 15
/****** Object: Stored Procedure dbo.sp_AllocBatchOfUniqueIDs_UniqueIDs Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_AllocBatchOfUniqueIDs_UniqueIDs]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_AllocBatchOfUniqueIDs_UniqueIDs]
GO
CREATE PROCEDURE [sp_AllocBatchOfUniqueIDs_UniqueIDs]
AS
IF (SELECT COUNT([StartingIDofCurrentBatch]) FROM [DNADesign].[dbo].[UniqueIDs]) = 0
INSERT INTO [DNADesign].[dbo].[UniqueIDs] ([StartingIDofCurrentBatch]) VALUES(0)
UPDATE [DNADesign].[dbo].[UniqueIDs]
SET [StartingIDofCurrentBatch] = [StartingIDofCurrentBatch] + 100
RETURN (SELECT [StartingIDofCurrentBatch] FROM [DNADesign].[dbo].[UniqueIDs])
GO
Listing 16
/****** Object: Stored Procedure dbo.sp_decrementBalance_Accounts Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_decrementBalance_Accounts]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_decrementBalance_Accounts]
GO
CREATE PROCEDURE [sp_decrementBalance_Accounts]
(@IDPK int,
@Amount money,
@Balance money OUTPUT,
@Limit money OUTPUT)
AS UPDATE [DNADesign].[dbo].[Accounts] SET Balance = Balance - @Amount WHERE ( [IDPK] = @IDPK)
SELECT @Balance = Balance, @Limit = Limit FROM [DNADesign].[dbo].[Accounts] WHERE ( [IDPK] = @IDPK)
GO
Listing 17
/****** Object: Stored Procedure dbo.sp_decrementQOH_Inventory Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_decrementQOH_Inventory]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_decrementQOH_Inventory]
GO
CREATE PROCEDURE [sp_decrementQOH_Inventory]
(@IDPK int,
@Quantity int)
AS UPDATE [DNADesign].[dbo].[Inventory] SET QOH = QOH - @Quantity WHERE ( [IDPK] = @IDPK)
RETURN (SELECT QOH FROM [DNADesign].[dbo].[Inventory] WHERE ( [IDPK] = @IDPK))
GO
Listing 18
/****** Object: Stored Procedure dbo.sp_delete_Accounts Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_delete_Accounts]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_delete_Accounts]
GO
CREATE PROCEDURE [sp_delete_Accounts]
(@IDPK int)
AS DELETE [DNADesign].[dbo].[Accounts]
WHERE
( [IDPK] = @IDPK)
GO
Listing 19
/****** Object: Stored Procedure dbo.sp_delete_Inventory Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_delete_Inventory]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_delete_Inventory]
GO
CREATE PROCEDURE [sp_delete_Inventory]
(@IDPK int)
AS DELETE [DNADesign].[dbo].[Inventory]
WHERE
( [IDPK] = @IDPK)
GO
Listing 20
/****** Object: Stored Procedure dbo.sp_delete_LineItems Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_delete_LineItems]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_delete_LineItems]
GO
CREATE PROCEDURE [sp_delete_LineItems]
(@IDPK int)
AS DELETE [DNADesign].[dbo].[LineItems]
WHERE
( [IDPK] = @IDPK)
GO
Listing 21
/****** Object: Stored Procedure dbo.sp_deleteByPurchaseOrder_LineItems Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_deleteByPurchaseOrder_LineItems]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_deleteByPurchaseOrder_LineItems]
GO
CREATE PROCEDURE [sp_deleteByPurchaseOrder_LineItems]
(@PurchaseOrderIDFK int)
AS
DELETE [DNADesign].[dbo].[LineItems] WHERE ([PurchaseOrderIDFK] = @PurchaseOrderIDFK)
GO
Listing 22
/****** Object: Stored Procedure dbo.sp_delete_PurchaseOrders Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_delete_PurchaseOrders]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_delete_PurchaseOrders]
GO
CREATE PROCEDURE [sp_delete_PurchaseOrders]
(@IDPK int)
AS EXEC sp_deleteByPurchaseOrder_LineItems @IDPK
DELETE [DNADesign].[dbo].[PurchaseOrders] WHERE ( [IDPK] = @IDPK)
GO
Listing 23
/****** Object: Stored Procedure dbo.sp_incrementBalance_Accounts Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_incrementBalance_Accounts]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_incrementBalance_Accounts]
GO
CREATE PROCEDURE [sp_incrementBalance_Accounts]
(@IDPK int,
@Amount money,
@Balance money OUTPUT,
@Limit money OUTPUT)
AS UPDATE [DNADesign].[dbo].[Accounts] SET Balance = Balance + @Amount WHERE ( [IDPK] = @IDPK)
SELECT @Balance = Balance, @Limit = Limit FROM [DNADesign].[dbo].[Accounts] WHERE ( [IDPK] = @IDPK)
GO
Listing 24
/****** Object: Stored Procedure dbo.sp_incrementQOH_Inventory Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_incrementQOH_Inventory]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_incrementQOH_Inventory]
GO
CREATE PROCEDURE [sp_incrementQOH_Inventory]
(@IDPK int,
@Quantity int)
AS UPDATE [DNADesign].[dbo].[Inventory] SET QOH = QOH + @Quantity WHERE ( [IDPK] = @IDPK)
RETURN (SELECT QOH FROM [DNADesign].[dbo].[Inventory] WHERE ( [IDPK] = @IDPK))
GO
Listing 25
/****** Object: Stored Procedure dbo.sp_insert_Accounts Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_insert_Accounts]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_insert_Accounts]
GO
CREATE PROCEDURE [sp_insert_Accounts]
(@IDPK int,
@FirstName varchar(20),
@LastName varchar(40),
@AddressLine1 varchar(20),
@AddressLine2 varchar(20),
@City varchar(20),
@State varchar(2),
@Zip varchar(5),
@Phone varchar(12),
@Email varchar(20),
@Balance money,
@Limit money)
AS INSERT INTO [DNADesign].[dbo].[Accounts]
( [IDPK],
[FirstName],
[LastName],
[AddressLine1],
[AddressLine2],
[City],
[State],
[Zip],
[Phone],
[Email],
[Balance],
[Limit])
VALUES
( @IDPK,
@FirstName,
@LastName,
@AddressLine1,
@AddressLine2,
@City,
@State,
@Zip,
@Phone,
@Email,
@Balance,
@Limit)
GO
Listing 26
/****** Object: Stored Procedure dbo.sp_insert_Inventory Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_insert_Inventory]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_insert_Inventory]
GO
CREATE PROCEDURE [sp_insert_Inventory]
(@IDPK int,
@Description varchar(50),
@Price money,
@QOH int)
AS INSERT INTO [DNADesign].[dbo].[Inventory]
( [IDPK],
[Description],
[Price],
[QOH])
VALUES
( @IDPK,
@Description,
@Price,
@QOH)
GO
Listing 27
/****** Object: Stored Procedure dbo.sp_insert_LineItems Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_insert_LineItems]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_insert_LineItems]
GO
CREATE PROCEDURE [sp_insert_LineItems]
(@IDPK int,
@PurchaseOrderIDFK int,
@InventoryIDFK int,
@Price money,
@Quantity int)
AS INSERT INTO [DNADesign].[dbo].[LineItems]
( [IDPK],
[PurchaseOrderIDFK],
[InventoryIDFK],
[Price],
[Quantity])
VALUES
( @IDPK,
@PurchaseOrderIDFK,
@InventoryIDFK,
@Price,
@Quantity)
GO
Listing 28
/****** Object: Stored Procedure dbo.sp_insert_PurchaseOrders Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_insert_PurchaseOrders]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_insert_PurchaseOrders]
GO
CREATE PROCEDURE [sp_insert_PurchaseOrders]
(@IDPK int,
@AccountIDFK int,
@ShippingHandling money,
@TaxRate real,
@Total money,
@ShipToFirstName varchar(20),
@ShipToLastName varchar(40),
@ShipToAddressLine1 varchar(20),
@ShipToAddressLine2 varchar(20),
@ShipToCity varchar(20),
@ShipToState varchar(2),
@ShipToZip varchar(5),
@ShipToPhone varchar(12),
@ShipToEmail varchar(20))
AS INSERT INTO [DNADesign].[dbo].[PurchaseOrders]
( [IDPK],
[AccountIDFK],
[ShippingHandling],
[TaxRate],
[Total],
[ShipToFirstName],
[ShipToLastName],
[ShipToAddressLine1],
[ShipToAddressLine2],
[ShipToCity],
[ShipToState],
[ShipToZip],
[ShipToPhone],
[ShipToEmail])
VALUES
( @IDPK,
@AccountIDFK,
@ShippingHandling,
@TaxRate,
@Total,
@ShipToFirstName,
@ShipToLastName,
@ShipToAddressLine1,
@ShipToAddressLine2,
@ShipToCity,
@ShipToState,
@ShipToZip,
@ShipToPhone,
@ShipToEmail)
GO
Listing 29
/****** Object: Stored Procedure dbo.sp_update_Accounts Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_update_Accounts]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_update_Accounts]
GO
CREATE PROCEDURE [sp_update_Accounts]
(@IDPK int,
@FirstName varchar(20),
@LastName varchar(40),
@AddressLine1 varchar(20),
@AddressLine2 varchar(20),
@City varchar(20),
@State varchar(2),
@Zip varchar(5),
@Phone varchar(12),
@Email varchar(20),
@Balance money,
@Limit money)
AS UPDATE [DNADesign].[dbo].[Accounts]
SET [FirstName] = @FirstName,
[LastName] = @LastName,
[AddressLine1] = @AddressLine1,
[AddressLine2] = @AddressLine2,
[City] = @City,
[State] = @State,
[Zip] = @Zip,
[Phone] = @Phone,
[Email] = @Email,
[Balance] = @Balance,
[Limit] = @Limit
WHERE
( [IDPK] = @IDPK)
GO
Listing 30
/****** Object: Stored Procedure dbo.sp_update_Inventory Script Date: 5/5/99 3:46:20 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_update_Inventory]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_update_Inventory]
GO
CREATE PROCEDURE [sp_update_Inventory]
(@IDPK int,
@Description varchar(50),
@Price money,
@QOH int)
AS UPDATE [DNADesign].[dbo].[Inventory]
SET [Description] = @Description,
[Price] = @Price,
[QOH] = @QOH
WHERE
( [IDPK] = @IDPK)
GO
Listing 31
/****** Object: Stored Procedure dbo.sp_update_LineItems Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_update_LineItems]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_update_LineItems]
GO
CREATE PROCEDURE [sp_update_LineItems]
(@IDPK int,
@PurchaseOrderIDFK int,
@InventoryIDFK int,
@Price money,
@Quantity int)
AS UPDATE [DNADesign].[dbo].[LineItems]
SET [PurchaseOrderIDFK] = @PurchaseOrderIDFK,
[InventoryIDFK] = @InventoryIDFK,
[Price] = @Price,
[Quantity] = @Quantity
WHERE
( [IDPK] = @IDPK)
GO
Listing 32
/****** Object: Stored Procedure dbo.sp_update_PurchaseOrders Script Date: 5/5/99 3:46:21 PM ******/
if exists (select * from sysobjects where id = object_id(N'[dbo].[sp_update_PurchaseOrders]') and OBJECTPROPERTY(id, N'IsProcedure') = 1)
drop procedure [dbo].[sp_update_PurchaseOrders]
GO
CREATE PROCEDURE [sp_update_PurchaseOrders]
(@IDPK int,
@AccountIDFK int,
@ShippingHandling money,
@TaxRate real,
@Total money,
@ShipToFirstName varchar(20),
@ShipToLastName varchar(40),
@ShipToAddressLine1 varchar(20),
@ShipToAddressLine2 varchar(20),
@ShipToCity varchar(20),
@ShipToState varchar(2),
@ShipToZip varchar(5),
@ShipToPhone varchar(12),
@ShipToEmail varchar(20))
AS UPDATE [DNADesign].[dbo].[PurchaseOrders]
SET [AccountIDFK] = @AccountIDFK,
[ShippingHandling] = @ShippingHandling,
[TaxRate] = @TaxRate,
[Total] = @Total,
[ShipToFirstName] = @ShipToFirstName,
[ShipToLastName] = @ShipToLastName,
[ShipToAddressLine1] = @ShipToAddressLine1,
[ShipToAddressLine2] = @ShipToAddressLine2,
[ShipToCity] = @ShipToCity,
[ShipToState] = @ShipToState,
[ShipToZip] = @ShipToZip,
[ShipToPhone] = @ShipToPhone,
[ShipToEmail] = @ShipToEmail
WHERE
( [IDPK] = @IDPK)
GO
Listing 33
' AccountExec
Option Explicit
Implements IAccountExec
' Use field aliases to associate object
' property names with field names from the
' underlying data source
Private Const mstrSQL = "SELECT IDPK AS ID, FirstName, LastName," & _
" AddressLine1, AddressLine2, City, State, Zip," & _
" Phone, Email, Balance, Limit FROM Accounts"
Private Function IAccountExec_Create(rIAccount As POInterfaces.IAccount, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rIAccountLocal As IAccount
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can create accounts
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIAccount.MarshalToPropertyBag(strKey)
Set rIAccountLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIAccountLocal = rIAccount
End If
' Make sure that the information is valid
If Not rIAccountLocal.Valid Then GoTo ErrorHandler
' Assign the new Account a unique ID
Set objUniqueIDGen = GetObjectContext.CreateInstance("POExecutants.UniqueIDGen")
rIAccountLocal.ID = objUniqueIDGen.GetNextUniqueID()
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_Accounts"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIAccountLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("FirstName", adVarChar, _
adParamInput, 20, rIAccountLocal.FirstName)
objCommand.Parameters.Append _
objCommand.CreateParameter("LastName", adVarChar, _
adParamInput, 40, rIAccountLocal.LastName)
objCommand.Parameters.Append _
objCommand.CreateParameter("AddressLine1", adVarChar, _
adParamInput, 20, rIAccountLocal.AddressLine1)
objCommand.Parameters.Append _
objCommand.CreateParameter("AddressLine2", adVarChar, _
adParamInput, 20, rIAccountLocal.AddressLine2)
objCommand.Parameters.Append _
objCommand.CreateParameter("City", adVarChar, _
adParamInput, 20, rIAccountLocal.City)
objCommand.Parameters.Append _
objCommand.CreateParameter("State", adVarChar, _
adParamInput, 2, rIAccountLocal.State)
objCommand.Parameters.Append _
objCommand.CreateParameter("Zip", adVarChar, _
adParamInput, 5, rIAccountLocal.Zip)
objCommand.Parameters.Append _
objCommand.CreateParameter("Phone", adVarChar, _
adParamInput, 12, rIAccountLocal.Phone)
objCommand.Parameters.Append _
objCommand.CreateParameter("Email", adVarChar, _
adParamInput, 20, rIAccountLocal.Email)
objCommand.Parameters.Append _
objCommand.CreateParameter("Balance", adCurrency, _
adParamInput, , rIAccountLocal.Balance)
objCommand.Parameters.Append _
objCommand.CreateParameter("Limit", adCurrency, _
adParamInput, , rIAccountLocal.Limit)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IAccountExec_Create = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rIAccountLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IAccountExec_CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
Dim objConnection As New Connection
Dim objRecordset As New Recordset
Dim strSQL As String
' Preprocess the incoming args
strFilter = Trim$(strFilter)
objConnection.Open "DSN=DNADesign"
objConnection.CursorLocation = adUseClient
If strFilter = "" Then
strSQL = mstrSQL
Else
strSQL = mstrSQL & " WHERE " & strFilter
End If
objRecordset.Open strSQL, objConnection
Set objRecordset.ActiveConnection = Nothing
Set IAccountExec_CreateRecordset = objRecordset
Set objRecordset = Nothing
Set objConnection = Nothing
GetObjectContext.SetComplete
End Function
Private Function IAccountExec_DecrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
Dim objCommand As New Command
Dim curBalance As Currency
Dim curLimit As Currency
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_decrementBalance_Accounts"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngAccountID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Amount", adCurrency, _
adParamInput, , curAmount)
objCommand.Parameters.Append _
objCommand.CreateParameter("Balance", adCurrency, _
adParamOutput)
objCommand.Parameters.Append _
objCommand.CreateParameter("Limit", adCurrency, _
adParamOutput)
' Execute the call
objCommand.Execute lngRecordsAffected
' Get the Account Balance
curBalance = objCommand.Parameters(2)
' Get the Account Limit
curLimit = objCommand.Parameters(3)
If lngRecordsAffected > 0 Then
' Balance cannot be negative
If curBalance >= 0 Then
GetObjectContext.SetComplete
IAccountExec_DecrementBalance = True
Else
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IAccountExec_Destroy(ByVal lngAccountID As Long) As Boolean
Dim objCommand As New Command
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can delete accounts
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_delete_Accounts"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngAccountID)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IAccountExec_Destroy = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IAccountExec_IncrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
Dim objCommand As New Command
Dim curBalance As Currency
Dim curLimit As Currency
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_incrementBalance_Accounts"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngAccountID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Amount", adCurrency, _
adParamInput, , curAmount)
objCommand.Parameters.Append _
objCommand.CreateParameter("Balance", adCurrency, _
adParamOutput)
objCommand.Parameters.Append _
objCommand.CreateParameter("Limit", adCurrency, _
adParamOutput)
' Execute the call
objCommand.Execute lngRecordsAffected
' Get the Account Balance
curBalance = objCommand.Parameters(2)
' Get the Account Limit
curLimit = objCommand.Parameters(3)
If lngRecordsAffected > 0 Then
' Make sure the new Balance is not
' beyond the Account Limit
If curBalance <= curLimit Then
GetObjectContext.SetComplete
IAccountExec_IncrementBalance = True
Else
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IAccountExec_Modify(rIAccount As POInterfaces.IAccount, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rIAccountLocal As IAccount
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can modify accounts
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIAccount.MarshalToPropertyBag(strKey)
Set rIAccountLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIAccountLocal = rIAccount
End If
' Make sure that the information is valid
If Not rIAccountLocal.Valid Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_update_Accounts"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIAccount.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("FirstName", adVarChar, _
adParamInput, 20, rIAccountLocal.FirstName)
objCommand.Parameters.Append _
objCommand.CreateParameter("LastName", adVarChar, _
adParamInput, 40, rIAccountLocal.LastName)
objCommand.Parameters.Append _
objCommand.CreateParameter("AddressLine1", adVarChar, _
adParamInput, 20, rIAccountLocal.AddressLine1)
objCommand.Parameters.Append _
objCommand.CreateParameter("AddressLine2", adVarChar, _
adParamInput, 20, rIAccountLocal.AddressLine2)
objCommand.Parameters.Append _
objCommand.CreateParameter("City", adVarChar, _
adParamInput, 20, rIAccountLocal.City)
objCommand.Parameters.Append _
objCommand.CreateParameter("State", adVarChar, _
adParamInput, 2, rIAccountLocal.State)
objCommand.Parameters.Append _
objCommand.CreateParameter("Zip", adVarChar, _
adParamInput, 5, rIAccountLocal.Zip)
objCommand.Parameters.Append _
objCommand.CreateParameter("Phone", adVarChar, _
adParamInput, 12, rIAccountLocal.Phone)
objCommand.Parameters.Append _
objCommand.CreateParameter("Email", adVarChar, _
adParamInput, 20, rIAccountLocal.Email)
objCommand.Parameters.Append _
objCommand.CreateParameter("Balance", adCurrency, _
adParamInput, , rIAccountLocal.Balance)
objCommand.Parameters.Append _
objCommand.CreateParameter("Limit", adCurrency, _
adParamInput, , rIAccountLocal.Limit)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IAccountExec_Modify = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rIAccountLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Listing 34
' InventoryExec
Option Explicit
Implements IInventoryExec
' Use field aliases to associate object
' property names with field names from the
' underlying data source
Private Const mstrSQL = "SELECT IDPK AS ID, Description, Price," & _
" QOH FROM Inventory"
Private Function IInventoryExec_Create(rIInventory As POInterfaces.IInventory, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rIInventoryLocal As IInventory
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can create inventory items
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIInventory.MarshalToPropertyBag(strKey)
Set rIInventoryLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIInventoryLocal = rIInventory
End If
' Make sure that the information is valid
If Not rIInventoryLocal.Valid Then GoTo ErrorHandler
' Assign the new Inventory item a unique ID
Set objUniqueIDGen = GetObjectContext.CreateInstance("POExecutants.UniqueIDGen")
rIInventoryLocal.ID = objUniqueIDGen.GetNextUniqueID()
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_Inventory"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIInventoryLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Description", adVarChar, _
adParamInput, 50, rIInventoryLocal.Description)
objCommand.Parameters.Append _
objCommand.CreateParameter("Price", adCurrency, _
adParamInput, , rIInventoryLocal.Price)
objCommand.Parameters.Append _
objCommand.CreateParameter("QOH", adInteger, _
adParamInput, , rIInventoryLocal.QOH)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IInventoryExec_Create = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rIInventoryLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IInventoryExec_CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
Dim objConnection As New Connection
Dim objRecordset As New Recordset
Dim strSQL As String
' Preprocess the incoming args
strFilter = Trim$(strFilter)
objConnection.Open "DSN=DNADesign"
objConnection.CursorLocation = adUseClient
If strFilter = "" Then
strSQL = mstrSQL
Else
strSQL = mstrSQL & " WHERE " & strFilter
End If
objRecordset.Open strSQL, objConnection
Set objRecordset.ActiveConnection = Nothing
Set IInventoryExec_CreateRecordset = objRecordset
Set objRecordset = Nothing
Set objConnection = Nothing
GetObjectContext.SetComplete
End Function
Private Function IInventoryExec_DecrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
Dim objCommand As New Command
Dim lngQOH As Long
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_decrementQOH_Inventory"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("Return", adInteger, _
adParamReturnValue)
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngInventoryID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Quantity", adInteger, _
adParamInput, , lngQuantity)
' Execute the call
objCommand.Execute lngRecordsAffected
' Get the return value
lngQOH = objCommand(0)
If lngRecordsAffected > 0 Then
' Balance in terms of credit cannot be negative
If lngQOH >= 0 Then
GetObjectContext.SetComplete
IInventoryExec_DecrementQOH = True
Else
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IInventoryExec_Destroy(ByVal lngInventoryID As Long) As Boolean
Dim objCommand As New Command
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can destroy inventory items
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_delete_Inventory"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngInventoryID)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IInventoryExec_Destroy = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IInventoryExec_IncrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
Dim objCommand As New Command
Dim lngQOH As Long
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_incrementQOH_Inventory"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("Return", adInteger, _
adParamReturnValue)
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngInventoryID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Quantity", adInteger, _
adParamInput, , lngQuantity)
' Execute the call
objCommand.Execute lngRecordsAffected
' Get the return value
lngQOH = objCommand(0)
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IInventoryExec_IncrementQOH = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IInventoryExec_Modify(rIInventory As POInterfaces.IInventory, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rIInventoryLocal As IInventory
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
' Only Administrators can modify inventory items
If Not GetObjectContext.IsCallerInRole("Administrators") Then GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIInventory.MarshalToPropertyBag(strKey)
Set rIInventoryLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIInventoryLocal = rIInventory
End If
' Make sure that the information is valid
If Not rIInventoryLocal.Valid Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_update_Inventory"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIInventoryLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Description", adVarChar, _
adParamInput, 50, rIInventoryLocal.Description)
objCommand.Parameters.Append _
objCommand.CreateParameter("Price", adCurrency, _
adParamInput, , rIInventoryLocal.Price)
objCommand.Parameters.Append _
objCommand.CreateParameter("QOH", adInteger, _
adParamInput, , rIInventoryLocal.QOH)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IInventoryExec_Modify = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rIInventoryLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Listing 35
' LineItemExec
Option Explicit
Implements ILineItemExec
' Use field aliases to associate object
' property names with field names from the
' underlying data source
Private Const mstrSQL = "SELECT LineItems.IDPK AS ID," & _
" PurchaseOrderIDFK AS PurchaseOrderID," & _
" LineItems.Price, LineItems.Quantity, " & _
" InventoryIDFK AS 'Inventory.ID'," & _
" Inventory.Description AS 'Inventory.Description'," & _
" Inventory.Price AS 'Inventory.Price'," & _
" Inventory.QOH AS 'Inventory.QOH' FROM LineItems, Inventory" & _
" WHERE InventoryIDFK = Inventory.IDPK"
Private Function ILineItemExec_Create(rILineItem As POInterfaces.ILineItem, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rILineItemLocal As ILineItem
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rILineItem.MarshalToPropertyBag(strKey)
Set rILineItemLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rILineItemLocal = rILineItem
End If
' Make sure that the information is valid
If Not rILineItemLocal.Valid Then GoTo ErrorHandler
' Assign the new LineItem a unique ID
Set objUniqueIDGen = GetObjectContext.CreateInstance("POExecutants.UniqueIDGen")
rILineItemLocal.ID = objUniqueIDGen.GetNextUniqueID()
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_LineItems"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rILineItemLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("PurchaseOrderIDFK", adInteger, _
adParamInput, , rILineItemLocal.PurchaseOrderID)
objCommand.Parameters.Append _
objCommand.CreateParameter("InventoryIDFK", adInteger, _
adParamInput, , rILineItemLocal.Item.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Price", adCurrency, _
adParamInput, , rILineItemLocal.Price)
objCommand.Parameters.Append _
objCommand.CreateParameter("Quantity", adInteger, _
adParamInput, , rILineItemLocal.Quantity)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
ILineItemExec_Create = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rILineItemLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function ILineItemExec_CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
Dim objConnection As New Connection
Dim objRecordset As New Recordset
Dim strSQL As String
' Preprocess the incoming args
strFilter = Trim$(strFilter)
objConnection.Open "DSN=DNADesign"
objConnection.CursorLocation = adUseClient
If strFilter = "" Then
strSQL = mstrSQL
Else
strSQL = mstrSQL & " AND (" & strFilter & ")"
End If
objRecordset.Open strSQL, objConnection
Set objRecordset.ActiveConnection = Nothing
Set ILineItemExec_CreateRecordset = objRecordset
Set objRecordset = Nothing
Set objConnection = Nothing
GetObjectContext.SetComplete
End Function
Private Function ILineItemExec_Destroy(ByVal lngLineItemID As Long) As Boolean
Dim objCommand As New Command
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_delete_LineItems"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngLineItemID)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
ILineItemExec_Destroy = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function ILineItemExec_DestroyByPurchaseOrder(ByVal lngPurchaseOrderID As Long) As Boolean
Dim objCommand As New Command
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_deleteByPurchaseOrder_LineItems"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("PurchaseOrderIDFK", adInteger, _
adParamInput, , lngPurchaseOrderID)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
ILineItemExec_DestroyByPurchaseOrder = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function ILineItemExec_Modify(rILineItem As POInterfaces.ILineItem, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rILineItemLocal As ILineItem
Dim strKey As String
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rILineItem.MarshalToPropertyBag(strKey)
Set rILineItemLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rILineItemLocal = rILineItem
End If
' Make sure that the information is valid
If Not rILineItemLocal.Valid Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_LineItems"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rILineItemLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("PurchaseOrderIDFK", adInteger, _
adParamInput, , rILineItemLocal.PurchaseOrderID)
objCommand.Parameters.Append _
objCommand.CreateParameter("InventoryIDFK", adInteger, _
adParamInput, , rILineItemLocal.Item.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("Price", adCurrency, _
adParamInput, , rILineItemLocal.Price)
objCommand.Parameters.Append _
objCommand.CreateParameter("Quantity", adInteger, _
adParamInput, , rILineItemLocal.Quantity)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
ILineItemExec_Modify = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rILineItemLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Listing 36
' PurchaseOrderExec
Option Explicit
Implements IPurchaseOrderExec
Private Function IPurchaseOrderExec_Cancel(ByVal lngPurchaseOrderID As Long) As Boolean
Dim objConnection As New Connection
Dim objRecordset As Recordset
Dim rIInventoryExec As IInventoryExec
Dim rIAccountExec As IAccountExec
Dim strSQL As String
On Error GoTo ErrorHandler
Set rIInventoryExec = GetObjectContext.CreateInstance("POExecutants.InventoryExec")
Set rIAccountExec = GetObjectContext.CreateInstance("POExecutants.AccountExec")
' Issue compensating transactions to increment the
' QOH of each Inventory item purchased as part of the order
strSQL = "SELECT InventoryIDFK, Quantity FROM LineItems WHERE PurchaseOrderIDFK = " & CStr(lngPurchaseOrderID)
objConnection.Open gstrCONNECT
Set objRecordset = objConnection.Execute(strSQL)
Do While Not objRecordset.EOF
If Not rIInventoryExec.IncrementQOH(objRecordset("InventoryIDFK"), objRecordset("Quantity")) Then
GoTo ErrorHandler
End If
objRecordset.MoveNext
Loop
objRecordset.Close
' Issue a compensating transaction to decrement the Account balance
strSQL = "SELECT AccountIDFK, Total FROM PurchaseOrders WHERE IDPK = " & CStr(lngPurchaseOrderID)
Set objRecordset = objConnection.Execute(strSQL)
If Not rIAccountExec.DecrementBalance(objRecordset("AccountIDFK"), objRecordset("Total")) Then
GoTo ErrorHandler
End If
' Delete the PurchaseOrder from the data source
If Not IPurchaseOrderExec_Destroy(lngPurchaseOrderID) Then
GoTo ErrorHandler
End If
GetObjectContext.SetComplete
IPurchaseOrderExec_Cancel = True
CleanUp:
Set rIAccountExec = Nothing
Set rIInventoryExec = Nothing
Set objRecordset = Nothing
Set objConnection = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IPurchaseOrderExec_Create(rIPurchaseOrder As POInterfaces.IPurchaseOrder, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objUniqueIDGen As UniqueIDGen
Dim objPropertyBag As New PropertyBag
Dim rIPurchaseOrderLocal As IPurchaseOrder
Dim rILineItemExec As ILineItemExec
Dim rIInventoryExec As IInventoryExec
Dim rIAccountExec As IAccountExec
Dim rILineItem As ILineItem
Dim strKey As String
Dim lngLineItem As Long
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIPurchaseOrder.MarshalToPropertyBag(strKey)
Set rIPurchaseOrderLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIPurchaseOrderLocal = rIPurchaseOrder
End If
' Make sure that the information is valid
If Not rIPurchaseOrderLocal.Valid Then GoTo ErrorHandler
' Assign the new PurchaseOrder a unique ID
Set objUniqueIDGen = GetObjectContext.CreateInstance("POExecutants.UniqueIDGen")
rIPurchaseOrderLocal.ID = objUniqueIDGen.GetNextUniqueID()
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_PurchaseOrders"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIPurchaseOrderLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("AccountIDFK", adInteger, _
adParamInput, , rIPurchaseOrderLocal.AccountID)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShippingHandling", adCurrency, _
adParamInput, , rIPurchaseOrderLocal.ShippingHandling)
objCommand.Parameters.Append _
objCommand.CreateParameter("TaxRate", adDouble, _
adParamInput, , rIPurchaseOrderLocal.TaxRate)
objCommand.Parameters.Append _
objCommand.CreateParameter("Total", adCurrency, _
adParamInput, , rIPurchaseOrderLocal.Total)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToFirstName", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToFirstName)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToLastName", adVarChar, _
adParamInput, 40, rIPurchaseOrderLocal.ShipToLastName)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToAddressLine1", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToAddressLine1)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToAddressLine2", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToAddressLine2)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToCity", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToCity)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToState", adVarChar, _
adParamInput, 2, rIPurchaseOrderLocal.ShipToState)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToZip", adVarChar, _
adParamInput, 5, rIPurchaseOrderLocal.ShipToZip)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToPhone", adVarChar, _
adParamInput, 12, rIPurchaseOrderLocal.ShipToPhone)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToEmail", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToEmail)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
Set rILineItemExec = GetObjectContext.CreateInstance("POExecutants.LineItemExec")
Set rIInventoryExec = GetObjectContext.CreateInstance("POExecutants.InventoryExec")
Set rIAccountExec = GetObjectContext.CreateInstance("POExecutants.AccountExec")
' Save the related LineItems
For lngLineItem = 1 To rIPurchaseOrderLocal.LineItems.Count
Set rILineItem = rIPurchaseOrderLocal.LineItems.Item(lngLineItem)
If Not rILineItem Is Nothing Then
rILineItem.PurchaseOrderID = rIPurchaseOrderLocal.ID
' Pass each LineItem ByRef since both
' components are in the same package
If rILineItemExec.Create(rILineItem, False) Then
' Decrement the QOH for each Inventory item
If Not rIInventoryExec.DecrementQOH(rILineItem.Item.ID, rILineItem.Quantity) Then
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
End If
Next lngLineItem
' Increment the Account balance
If Not rIAccountExec.IncrementBalance(rIPurchaseOrderLocal.AccountID, rIPurchaseOrderLocal.Total) Then
GoTo ErrorHandler
End If
GetObjectContext.SetComplete
IPurchaseOrderExec_Create = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set rILineItem = Nothing
Set rIAccountExec = Nothing
Set rIInventoryExec = Nothing
Set rILineItemExec = Nothing
Set rIPurchaseOrderLocal = Nothing
Set objPropertyBag = Nothing
Set objUniqueIDGen = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IPurchaseOrderExec_CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
Dim objConnection As New Connection
Dim objRecordset As New Recordset
Dim strParentCommand As String
Dim strChildCommand As String
Dim strSQL As String
' Preprocess the incoming args
strFilter = Trim$(strFilter)
objConnection.Provider = "MSDataShape"
objConnection.Open "DSN=DNADesign"
objConnection.CursorLocation = adUseClient
' Use field aliases to associate object
' property names with field names from the
' underlying data source
If strFilter = "" Then
strParentCommand = "SELECT IDPK AS ID," & _
" AccountIDFK AS 'Account.ID', OrderDate," & _
" ShippingHandling, TaxRate, Total," & _
" ShipToFirstName, ShipToLastName, ShipToAddressLine1," & _
" ShipToAddressLine2, ShipToCity, ShipToState, ShipToZip," & _
" ShipToPhone, ShipToEmail" & _
" FROM PurchaseOrders"
Else
strParentCommand = "SELECT IDPK AS ID," & _
" AccountIDFK AS 'Account.ID', OrderDate," & _
" ShippingHandling, TaxRate, Total," & _
" ShipToFirstName, ShipToLastName, ShipToAddressLine1," & _
" ShipToAddressLine2, ShipToCity, ShipToState, ShipToZip," & _
" ShipToPhone, ShipToEmail" & _
" FROM PurchaseOrders" & _
" WHERE " & strFilter
End If
strChildCommand = "SELECT LineItems.IDPK AS ID," & _
" PurchaseOrderIDFK AS PurchaseOrderID," & _
" LineItems.Price, LineItems.Quantity, " & _
" InventoryIDFK AS 'Inventory.ID'," & _
" Inventory.Description AS 'Inventory.Description'," & _
" Inventory.Price AS 'Inventory.Price'," & _
" Inventory.QOH AS 'Inventory.QOH' FROM LineItems, Inventory" & _
" WHERE InventoryIDFK = Inventory.IDPK"
strSQL = "SHAPE {" & strParentCommand & _
"} APPEND ({" & strChildCommand & _
"} RELATE ID TO PurchaseOrderID) AS chapPurchaseOrderLineItems"
objRecordset.Open strSQL, objConnection
Set objRecordset.ActiveConnection = Nothing
Set IPurchaseOrderExec_CreateRecordset = objRecordset
Set objRecordset = Nothing
Set objConnection = Nothing
GetObjectContext.SetComplete
End Function
Private Function IPurchaseOrderExec_Destroy(ByVal lngPurchaseOrderID As Long) As Boolean
Dim objCommand As New Command
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_delete_PurchaseOrders"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , lngPurchaseOrderID)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
GetObjectContext.SetComplete
IPurchaseOrderExec_Destroy = True
Else
GoTo ErrorHandler
End If
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Private Function IPurchaseOrderExec_Modify(rIPurchaseOrder As POInterfaces.IPurchaseOrder, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim objCommand As New Command
Dim objPropertyBag As New PropertyBag
Dim rIPurchaseOrderLocal As IPurchaseOrder
Dim rILineItemExec As ILineItemExec
Dim rIInventoryExec As IInventoryExec
Dim rIAccountExec As IAccountExec
Dim rILineItem As ILineItem
Dim strKey As String
Dim lngLineItem As Long
Dim lngRecordsAffected As Long
On Error GoTo ErrorHandler
If blnByVal Then
' Create a local copy of the object
objPropertyBag.Contents = rIPurchaseOrder.MarshalToPropertyBag(strKey)
Set rIPurchaseOrderLocal = objPropertyBag.ReadProperty(strKey, Nothing)
Else
' Use the object ByRef
Set rIPurchaseOrderLocal = rIPurchaseOrder
End If
' Make sure that the information is valid
If Not rIPurchaseOrderLocal.Valid Then GoTo ErrorHandler
' Cancel the existing purchase order
If Not IPurchaseOrderExec_Cancel(rIPurchaseOrderLocal.ID) Then GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_insert_PurchaseOrders"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("IDPK", adInteger, _
adParamInput, , rIPurchaseOrderLocal.ID)
objCommand.Parameters.Append _
objCommand.CreateParameter("AccountIDFK", adInteger, _
adParamInput, , rIPurchaseOrderLocal.AccountID)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShippingHandling", adCurrency, _
adParamInput, , rIPurchaseOrderLocal.ShippingHandling)
objCommand.Parameters.Append _
objCommand.CreateParameter("TaxRate", adDouble, _
adParamInput, , rIPurchaseOrderLocal.TaxRate)
objCommand.Parameters.Append _
objCommand.CreateParameter("Total", adCurrency, _
adParamInput, , rIPurchaseOrderLocal.Total)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToFirstName", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToFirstName)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToLastName", adVarChar, _
adParamInput, 40, rIPurchaseOrderLocal.ShipToLastName)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToAddressLine1", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToAddressLine1)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToAddressLine2", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToAddressLine2)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToCity", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToCity)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToState", adVarChar, _
adParamInput, 2, rIPurchaseOrderLocal.ShipToState)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToZip", adVarChar, _
adParamInput, 5, rIPurchaseOrderLocal.ShipToZip)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToPhone", adVarChar, _
adParamInput, 12, rIPurchaseOrderLocal.ShipToPhone)
objCommand.Parameters.Append _
objCommand.CreateParameter("ShipToEmail", adVarChar, _
adParamInput, 20, rIPurchaseOrderLocal.ShipToEmail)
' Execute the call
objCommand.Execute lngRecordsAffected
If lngRecordsAffected > 0 Then
Set rILineItemExec = GetObjectContext.CreateInstance("POExecutants.LineItemExec")
Set rIInventoryExec = GetObjectContext.CreateInstance("POExecutants.InventoryExec")
Set rIAccountExec = GetObjectContext.CreateInstance("POExecutants.AccountExec")
' Save the related LineItems
For lngLineItem = 1 To rIPurchaseOrderLocal.LineItems.Count
Set rILineItem = rIPurchaseOrderLocal.LineItems.Item(lngLineItem)
If Not rILineItem Is Nothing Then
rILineItem.PurchaseOrderID = rIPurchaseOrderLocal.ID
' Pass each LineItem ByRef since both
' components are in the same package
If rILineItemExec.Create(rILineItem, False) Then
' Decrement the QOH for each Inventory item
If Not rIInventoryExec.DecrementQOH(rILineItem.Item.ID, rILineItem.Quantity) Then
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
End If
Next lngLineItem
' Increment the Account balance
If Not rIAccountExec.IncrementBalance(rIPurchaseOrderLocal.AccountID, rIPurchaseOrderLocal.Total) Then
GoTo ErrorHandler
End If
Else
GoTo ErrorHandler
End If
'
GetObjectContext.SetComplete
IPurchaseOrderExec_Modify = True
CleanUp:
Set rILineItem = Nothing
Set rIAccountExec = Nothing
Set rIInventoryExec = Nothing
Set rILineItemExec = Nothing
Set rIPurchaseOrderLocal = Nothing
Set objPropertyBag = Nothing
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GoTo CleanUp
End Function
Listing 37
Public Function Create(vntAccount As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIAccount As IAccount
' Cast the generic object reference
' into a specific object type
If VarType(vntAccount) = vbObject Then
Set rIAccount = vntAccount
' Delegate the default interface implementation
' to the appropriate interface implementation
Create = IAccountExec_Create(rIAccount, blnByVal)
End If
Set rIAccount = Nothing
End Function
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
' Delegate the default interface implementation
' to the appropriate interface implementation
Set CreateRecordset = IAccountExec_CreateRecordset(strFilter)
End Function
Public Function Destroy(ByVal lngAccountID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Destroy = IAccountExec_Destroy(lngAccountID)
End Function
Public Function Modify(vntAccount As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIAccount As IAccount
' Cast the generic object reference
' into a specific object type
If VarType(vntAccount) = vbObject Then
Set rIAccount = vntAccount
' Delegate the default interface implementation
' to the appropriate interface implementation
Modify = IAccountExec_Modify(rIAccount, blnByVal)
End If
Set rIAccount = Nothing
End Function
Public Function IncrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
IncrementBalance = IAccountExec_IncrementBalance(lngAccountID, curAmount)
End Function
Public Function DecrementBalance(ByVal lngAccountID As Long, ByVal curAmount As Currency) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
DecrementBalance = IAccountExec_DecrementBalance(lngAccountID, curAmount)
End Function
Listing 38
Public Function Create(vntInventory As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIInventory As IInventory
' Cast the generic object reference
' into a specific object type
If VarType(vntInventory) = vbObject Then
Set rIInventory = vntInventory
' Delegate the default interface implementation
' to the appropriate interface implementation
Create = IInventoryExec_Create(rIInventory, blnByVal)
End If
Set rIInventory = Nothing
End Function
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
' Delegate the default interface implementation
' to the appropriate interface implementation
Set CreateRecordset = IInventoryExec_CreateRecordset(strFilter)
End Function
Public Function Destroy(ByVal lngInventoryID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Destroy = IInventoryExec_Destroy(lngInventoryID)
End Function
Public Function IncrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
IncrementQOH = IInventoryExec_IncrementQOH(lngInventoryID, lngQuantity)
End Function
Public Function DecrementQOH(ByVal lngInventoryID As Long, ByVal lngQuantity As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
DecrementQOH = IInventoryExec_DecrementQOH(lngInventoryID, lngQuantity)
End Function
Public Function Modify(vntInventory As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIInventory As IInventory
' Cast the generic object reference
' into a specific object type
If VarType(vntInventory) = vbObject Then
Set rIInventory = vntInventory
' Delegate the default interface implementation
' to the appropriate interface implementation
Modify = IInventoryExec_Modify(rIInventory, blnByVal)
End If
Set rIInventory = Nothing
End Function
Listing 39
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
' Delegate the default interface implementation
' to the appropriate interface implementation
Set CreateRecordset = ILineItemExec_CreateRecordset(strFilter)
End Function
Public Function Create(vntLineItem As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rILineItem As ILineItem
' Cast the generic object reference
' into a specific object type
If VarType(vntLineItem) = vbObject Then
Set rILineItem = vntLineItem
' Delegate the default interface implementation
' to the appropriate interface implementation
Create = ILineItemExec_Create(rILineItem, blnByVal)
End If
Set rILineItem = Nothing
End Function
Public Function Destroy(ByVal lngLineItemID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Destroy = ILineItemExec_Destroy(lngLineItemID)
End Function
Public Function DestroyByPurchaseOrder(ByVal lngLineItemID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
DestroyByPurchaseOrder = ILineItemExec_DestroyByPurchaseOrder(lngLineItemID)
End Function
Public Function Modify(vntLineItem As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rILineItem As ILineItem
' Cast the generic object reference
' into a specific object type
If VarType(vntLineItem) = vbObject Then
Set rILineItem = vntLineItem
' Delegate the default interface implementation
' to the appropriate interface implementation
Modify = ILineItemExec_Modify(rILineItem, blnByVal)
End If
Set rILineItem = Nothing
End Function
Listing 40
Public Function CreateRecordset(Optional ByVal strFilter As String = "") As ADODB.Recordset
' Delegate the default interface implementation
' to the appropriate interface implementation
Set CreateRecordset = IPurchaseOrderExec_CreateRecordset(strFilter)
End Function
Public Function Create(vntPurchaseOrder As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIPurchaseOrder As IPurchaseOrder
' Cast the generic object reference
' into a specific object type
If VarType(vntPurchaseOrder) = vbObject Then
Set rIPurchaseOrder = vntPurchaseOrder
' Delegate the default interface implementation
' to the appropriate interface implementation
Create = IPurchaseOrderExec_Create(rIPurchaseOrder, blnByVal)
End If
Set rIPurchaseOrder = Nothing
End Function
Public Function Destroy(ByVal lngPurchaseOrderID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Destroy = IPurchaseOrderExec_Destroy(lngPurchaseOrderID)
End Function
Public Function Modify(vntPurchaseOrder As Variant, Optional ByVal blnByVal As Boolean = True) As Boolean
Dim rIPurchaseOrder As IPurchaseOrder
' Cast the generic object reference
' into a specific object type
If VarType(vntPurchaseOrder) = vbObject Then
Set rIPurchaseOrder = vntPurchaseOrder
' Delegate the default interface implementation
' to the appropriate interface implementation
Modify = IPurchaseOrderExec_Modify(rIPurchaseOrder, blnByVal)
End If
Set rIPurchaseOrder = Nothing
End Function
Public Function Cancel(ByVal lngPurchaseOrderID As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Cancel = IPurchaseOrderExec_Cancel(lngPurchaseOrderID)
End Function
Listing 41
' UniqueIDAllocBatch
Option Explicit
Public Function AllocBatchOfUniqueIDs() As Long
Dim objCommand As New Command
Dim lngNextReceipt As Long
On Error GoTo ErrorHandler
objCommand.ActiveConnection = gstrCONNECT
objCommand.CommandText = "sp_AllocBatchOfUniqueIDs_UniqueIDs"
objCommand.CommandType = adCmdStoredProc
' Create each parameter and supply it's data
objCommand.Parameters.Append _
objCommand.CreateParameter("Return", adInteger, _
adParamReturnValue)
' Execute the call
objCommand.Execute
' Get the return value
lngNextReceipt = objCommand(0)
GetObjectContext.SetComplete
AllocBatchOfUniqueIDs = lngNextReceipt
CleanUp:
Set objCommand = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
AllocBatchOfUniqueIDs = -1
GoTo CleanUp
End Function
Listing 42
' UniqueIDGen
Option Explicit
Public Function GetNextUniqueID() As Long
Dim objSPMMgr As SharedPropertyGroupManager
Dim objSPMGroup As SharedPropertyGroup
Dim objSPMPropNextUniqueID As SharedProperty
Dim objSPMPropMaxIDOfCurrentBatch As SharedProperty
Dim objUniqueIDAllocBatch As UniqueIDAllocBatch
Dim blnResult As Boolean
On Error GoTo ErrorHandler
' If Shared property does not already exist it will be initialized
Set objSPMMgr = GetObjectContext.CreateInstance("MTxSpm.SharedPropertyGroupManager.1")
Set objSPMGroup = objSPMMgr.CreatePropertyGroup("UniqueIDs", LockMethod, Process, blnResult)
Set objSPMPropNextUniqueID = objSPMGroup.CreateProperty("NextID", blnResult)
Set objSPMPropMaxIDOfCurrentBatch = objSPMGroup.CreateProperty("MaxID", blnResult)
' Set the initial value of the Shared Property to
' 0 if the Shared Property didn't already exist.
' This is not entirely necessary but demonstrates how to initialize a value.
If blnResult = False Then
objSPMPropNextUniqueID.Value = 0
End If
If objSPMPropNextUniqueID.Value >= objSPMPropMaxIDOfCurrentBatch.Value Then
Set objUniqueIDAllocBatch = GetObjectContext.CreateInstance("POExecutants.UniqueIDAllocBatch")
objSPMPropNextUniqueID.Value = objUniqueIDAllocBatch.AllocBatchOfUniqueIDs()
Set objUniqueIDAllocBatch = Nothing
objSPMPropMaxIDOfCurrentBatch.Value = objSPMPropNextUniqueID.Value + 100
End If
' Get the next unique number and update property
objSPMPropNextUniqueID.Value = objSPMPropNextUniqueID.Value + 1
GetObjectContext.SetComplete
GetNextUniqueID = objSPMPropNextUniqueID.Value
CleanUp:
Set objSPMMgr = Nothing
Set objSPMGroup = Nothing
Set objSPMPropNextUniqueID = Nothing
Set objSPMPropMaxIDOfCurrentBatch = Nothing
Set objUniqueIDAllocBatch = Nothing
Exit Function
ErrorHandler:
GetObjectContext.SetAbort
GetNextUniqueID = -1
GoTo CleanUp
End Function
Listing 43
' AccountIterator
Option Explicit
' Define ADODB.Field variables to bind to each
' column of the recordset
Private mfldID As Field
Private mfldFirstName As Field
Private mfldLastName As Field
Private mfldAddressLine1 As Field
Private mfldAddressLine2 As Field
Private mfldCity As Field
Private mfldState As Field
Private mfldZip As Field
Private mfldPhone As Field
Private mfldEmail As Field
Private mfldBalance As Field
Private mfldLimit As Field
Private mrs As Recordset
Public Property Let AbsolutePage(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePage = RHS
End Property
Public Property Get AbsolutePage() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePage = mrs.AbsolutePage
End Property
Public Property Let AbsolutePosition(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePosition = RHS
End Property
Public Property Get AbsolutePosition() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePosition = mrs.AbsolutePosition
End Property
Public Property Get BOF() As Boolean
' Delegate to the private ADO recordset
BOF = mrs.BOF
End Property
Public Property Let Bookmark(ByVal RHS As Variant)
' Delegate to the private ADO recordset
mrs.Bookmark = RHS
End Property
Public Property Get Bookmark() As Variant
' Delegate to the private ADO recordset
Bookmark = mrs.Bookmark
End Property
Public Property Let CacheSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.CacheSize = RHS
End Property
Public Property Get CacheSize() As Long
' Delegate to the private ADO recordset
CacheSize = mrs.CacheSize
End Property
Public Function Clone(Optional LockType As ADODB.LockTypeEnum = adLockUnspecified) As ADODB.Recordset
' Delegate to the private ADO recordset
Set Clone = mrs.Clone(LockType)
End Function
Public Property Get EOF() As Boolean
' Delegate to the private ADO recordset
EOF = mrs.EOF
End Property
Public Property Let Filter(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Filter = RHS
End Property
Public Property Get Filter() As String
' Delegate to the private ADO recordset
Filter = mrs.Filter
End Property
Public Function Initialize(Optional ByVal strFilter As String = "") As Boolean
Dim objAccountExec As Object
' To minimize network traffic, only send
' pre-validated requests to the executant
Set objAccountExec = CreateObject("POExecutants.AccountExec")
Set mrs = objAccountExec.CreateRecordset(strFilter)
If Not mrs Is Nothing Then
' Bind to the columns of the recordset
BindToRecordsetFields
Initialize = True
End If
' Clean Up
Set objAccountExec = Nothing
End Function
Public Property Get Item() As Object
Dim objAccount As New Account
' Initialize the return value
Set Item = Nothing
' Configure the object to return
objAccount.ID = mfldID
objAccount.FirstName = mfldFirstName
objAccount.LastName = mfldLastName
objAccount.AddressLine1 = mfldAddressLine1
objAccount.AddressLine2 = mfldAddressLine2
objAccount.City = mfldCity
objAccount.State = mfldState
objAccount.Zip = mfldZip
objAccount.Phone = mfldPhone
objAccount.Email = mfldEmail
objAccount.Balance = mfldBalance
objAccount.Limit = mfldLimit
' Return the object
Set Item = objAccount
' Clean up
Set objAccount = Nothing
End Property
Public Property Let MaxRecords(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.MaxRecords = RHS
End Property
Public Property Get MaxRecords() As Long
' Delegate to the private ADO recordset
MaxRecords = mrs.MaxRecords
End Property
Public Sub Move(ByVal NumRecords As Long, Optional Start As Variant = adBookmarkCurrent)
' Delegate to the private ADO recordset
mrs.Move NumRecords, Start
End Sub
Public Sub MoveFirst()
' Delegate to the private ADO recordset
mrs.MoveFirst
End Sub
Public Sub MoveLast()
' Delegate to the private ADO recordset
mrs.MoveLast
End Sub
Public Sub MoveNext()
' Delegate to the private ADO recordset
mrs.MoveNext
End Sub
Public Sub MovePrevious()
' Delegate to the private ADO recordset
mrs.MovePrevious
End Sub
Public Property Get PageCount() As Long
' Delegate to the private ADO recordset
PageCount = mrs.PageCount
End Property
Public Property Let PageSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.PageSize = RHS
End Property
Public Property Get PageSize() As Long
' Delegate to the private ADO recordset
PageSize = mrs.PageSize
End Property
Public Property Get RecordCount() As Long
' Delegate to the private ADO recordset
RecordCount = mrs.RecordCount
End Property
Public Property Let Sort(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Sort = RHS
End Property
Public Property Get Sort() As String
' Delegate to the private ADO recordset
Sort = mrs.Sort
End Property
Public Property Get State() As Long
' Delegate to the private ADO recordset
State = mrs.State
End Property
Private Sub BindToRecordsetFields()
' Bind the module-level ADODB.Field variables
' to the columns of the recordset
If Not mrs Is Nothing Then
Set mfldID = mrs("ID")
Set mfldFirstName = mrs("FirstName")
Set mfldLastName = mrs("LastName")
Set mfldAddressLine1 = mrs("AddressLine1")
Set mfldAddressLine2 = mrs("AddressLine2")
Set mfldCity = mrs("City")
Set mfldState = mrs("State")
Set mfldZip = mrs("Zip")
Set mfldPhone = mrs("Phone")
Set mfldEmail = mrs("Email")
Set mfldBalance = mrs("Balance")
Set mfldLimit = mrs("Limit")
End If
End Sub
Private Sub Class_Terminate()
' Release any module-level ADODB.Field references
Set mfldPhone = Nothing
Set mfldZip = Nothing
Set mfldState = Nothing
Set mfldCity = Nothing
Set mfldAddressLine1 = Nothing
Set mfldAddressLine2 = Nothing
Set mfldLastName = Nothing
Set mfldFirstName = Nothing
Set mfldID = Nothing
' Release any outstanding Recordset references
Set mrs = Nothing
End Sub
Listing 44
' InventoryIterator
Option Explicit
' Define ADODB.Field variables to bind to each
' column of the recordset
Private mfldID As Field
Private mfldDescription As Field
Private mfldPrice As Field
Private mfldQOH As Field
Private mrs As Recordset
Public Function Initialize(Optional ByVal strFilter As String = "") As Boolean
Dim objInventoryExec As Object
' To minimize network traffic, only send
' pre-validated requests to the executant
Set objInventoryExec = CreateObject("POExecutants.InventoryExec")
Set mrs = objInventoryExec.CreateRecordset(strFilter)
If Not mrs Is Nothing Then
' Bind to the columns of the recordset
BindToRecordsetFields
Initialize = True
End If
' Clean Up
Set objInventoryExec = Nothing
End Function
Public Property Get Item() As Object
Dim objInventory As New Inventory
' Initialize the return value
Set Item = Nothing
' Configure the object to return
objInventory.ID = mfldID
objInventory.Description = mfldDescription
objInventory.Price = mfldPrice
objInventory.QOH = mfldQOH
' Return the object
Set Item = objInventory
' Clean up
Set objInventory = Nothing
End Property
Private Sub BindToRecordsetFields()
' Bind the module-level ADODB.Field variables
' to the columns of the recordset
If Not mrs Is Nothing Then
Set mfldID = mrs("ID")
Set mfldDescription = mrs("Description")
Set mfldPrice = mrs("Price")
Set mfldQOH = mrs("QOH")
End If
End Sub
Private Sub Class_Terminate()
' Release any module-level ADODB.Field references
Set mfldQOH = Nothing
Set mfldPrice = Nothing
Set mfldDescription = Nothing
Set mfldID = Nothing
Set mrs = Nothing
' Release any outstanding Recordset references
Set mrs = Nothing
End Sub
Public Property Let AbsolutePage(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePage = RHS
End Property
Public Property Get AbsolutePage() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePage = mrs.AbsolutePage
End Property
Public Property Let AbsolutePosition(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePosition = RHS
End Property
Public Property Get AbsolutePosition() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePosition = mrs.AbsolutePosition
End Property
Public Property Get BOF() As Boolean
' Delegate to the private ADO recordset
BOF = mrs.BOF
End Property
Public Property Let Bookmark(ByVal RHS As Variant)
' Delegate to the private ADO recordset
mrs.Bookmark = RHS
End Property
Public Property Get Bookmark() As Variant
' Delegate to the private ADO recordset
Bookmark = mrs.Bookmark
End Property
Public Property Let CacheSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.CacheSize = RHS
End Property
Public Property Get CacheSize() As Long
' Delegate to the private ADO recordset
CacheSize = mrs.CacheSize
End Property
Public Function Clone(Optional LockType As ADODB.LockTypeEnum = adLockUnspecified) As ADODB.Recordset
' Delegate to the private ADO recordset
Set Clone = mrs.Clone(LockType)
End Function
Public Property Get EOF() As Boolean
' Delegate to the private ADO recordset
EOF = mrs.EOF
End Property
Public Property Let Filter(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Filter = RHS
End Property
Public Property Get Filter() As String
' Delegate to the private ADO recordset
Filter = mrs.Filter
End Property
Public Property Let MaxRecords(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.MaxRecords = RHS
End Property
Public Property Get MaxRecords() As Long
' Delegate to the private ADO recordset
MaxRecords = mrs.MaxRecords
End Property
Public Sub Move(ByVal NumRecords As Long, Optional Start As Variant = adBookmarkCurrent)
' Delegate to the private ADO recordset
mrs.Move NumRecords, Start
End Sub
Public Sub MoveFirst()
' Delegate to the private ADO recordset
mrs.MoveFirst
End Sub
Public Sub MoveLast()
' Delegate to the private ADO recordset
mrs.MoveLast
End Sub
Public Sub MoveNext()
' Delegate to the private ADO recordset
mrs.MoveNext
End Sub
Public Sub MovePrevious()
' Delegate to the private ADO recordset
mrs.MovePrevious
End Sub
Public Property Get PageCount() As Long
' Delegate to the private ADO recordset
PageCount = mrs.PageCount
End Property
Public Property Let PageSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.PageSize = RHS
End Property
Public Property Get PageSize() As Long
' Delegate to the private ADO recordset
PageSize = mrs.PageSize
End Property
Public Property Get RecordCount() As Long
' Delegate to the private ADO recordset
RecordCount = mrs.RecordCount
End Property
Public Property Let Sort(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Sort = RHS
End Property
Public Property Get Sort() As String
' Delegate to the private ADO recordset
Sort = mrs.Sort
End Property
Public Property Get State() As Long
' Delegate to the private ADO recordset
State = mrs.State
End Property
Listing 45
' LineItemIterator
Option Explicit
' Define ADODB.Field variables to bind to each
' column of the recordset
Private mfldID As Field
Private mfldPurchaseOrderID As Field
Private mfldPrice As Field
Private mfldQuantity As Field
'
Private mfldInventoryID As Field
Private mfldInventoryDescription As Field
Private mfldInventoryPrice As Field
Private mfldInventoryQOH As Field
Private mrs As Recordset
Public Function Initialize(Optional ByVal strFilter As String = "") As Boolean
Dim objLineItemExec As Object
' To minimize network traffic, only send
' pre-validated requests to the executant
Set objLineItemExec = CreateObject("POExecutants.LineItemExec")
Set mrs = objLineItemExec.CreateRecordset(strFilter)
If Not mrs Is Nothing Then
' Bind to the columns of the recordset
BindToRecordsetFields
Initialize = True
End If
' Clean Up
Set objLineItemExec = Nothing
End Function
Public Property Get Item() As Object
Dim objLineItem As New LineItem
Dim objInventory As New Inventory
' Initialize the return value
Set Item = Nothing
' Configure the object to return
objLineItem.ID = mfldID
objLineItem.PurchaseOrderID = mfldPurchaseOrderID
'
objInventory.ID = mfldInventoryID
objInventory.Description = mfldInventoryDescription
objInventory.Price = mfldInventoryPrice
objInventory.QOH = mfldInventoryQOH
'
Set objLineItem.Item = objInventory
objLineItem.Price = mfldPrice
objLineItem.Quantity = mfldQuantity
' Return the object
Set Item = objLineItem
' Clean up
Set objInventory = Nothing
Set objLineItem = Nothing
End Property
Private Sub BindToRecordsetFields()
' Bind the module-level ADODB.Field variables
' to the columns of the recordset
If Not mrs Is Nothing Then
Set mfldID = mrs("ID")
Set mfldPurchaseOrderID = mrs("PurchaseOrderID")
Set mfldPrice = mrs("Price")
Set mfldQuantity = mrs("Quantity")
Set mfldInventoryID = mrs("Inventory.ID")
Set mfldInventoryDescription = mrs("Inventory.Description")
Set mfldInventoryPrice = mrs("Inventory.Price")
Set mfldInventoryQOH = mrs("Inventory.QOH")
End If
End Sub
Private Sub Class_Terminate()
' Release any module-level ADODB.Field references
Set mfldInventoryQOH = Nothing
Set mfldInventoryPrice = Nothing
Set mfldInventoryDescription = Nothing
'
Set mfldQuantity = Nothing
Set mfldPrice = Nothing
Set mfldInventoryID = Nothing
Set mfldPurchaseOrderID = Nothing
Set mfldID = Nothing
' Release any outstanding Recordset references
Set mrs = Nothing
End Sub
Public Property Let AbsolutePage(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePage = RHS
End Property
Public Property Get AbsolutePage() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePage = mrs.AbsolutePage
End Property
Public Property Let AbsolutePosition(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePosition = RHS
End Property
Public Property Get AbsolutePosition() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePosition = mrs.AbsolutePosition
End Property
Public Property Get BOF() As Boolean
' Delegate to the private ADO recordset
BOF = mrs.BOF
End Property
Public Property Let Bookmark(ByVal RHS As Variant)
' Delegate to the private ADO recordset
mrs.Bookmark = RHS
End Property
Public Property Get Bookmark() As Variant
' Delegate to the private ADO recordset
Bookmark = mrs.Bookmark
End Property
Public Property Let CacheSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.CacheSize = RHS
End Property
Public Property Get CacheSize() As Long
' Delegate to the private ADO recordset
CacheSize = mrs.CacheSize
End Property
Public Function Clone(Optional LockType As ADODB.LockTypeEnum = adLockUnspecified) As ADODB.Recordset
' Delegate to the private ADO recordset
Set Clone = mrs.Clone(LockType)
End Function
Public Property Get EOF() As Boolean
' Delegate to the private ADO recordset
EOF = mrs.EOF
End Property
Public Property Let Filter(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Filter = RHS
End Property
Public Property Get Filter() As String
' Delegate to the private ADO recordset
Filter = mrs.Filter
End Property
Public Property Let MaxRecords(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.MaxRecords = RHS
End Property
Public Property Get MaxRecords() As Long
' Delegate to the private ADO recordset
MaxRecords = mrs.MaxRecords
End Property
Public Sub Move(ByVal NumRecords As Long, Optional Start As Variant = adBookmarkCurrent)
' Delegate to the private ADO recordset
mrs.Move NumRecords, Start
End Sub
Public Sub MoveFirst()
' Delegate to the private ADO recordset
mrs.MoveFirst
End Sub
Public Sub MoveLast()
' Delegate to the private ADO recordset
mrs.MoveLast
End Sub
Public Sub MoveNext()
' Delegate to the private ADO recordset
mrs.MoveNext
End Sub
Public Sub MovePrevious()
' Delegate to the private ADO recordset
mrs.MovePrevious
End Sub
Public Property Get PageCount() As Long
' Delegate to the private ADO recordset
PageCount = mrs.PageCount
End Property
Public Property Let PageSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.PageSize = RHS
End Property
Public Property Get PageSize() As Long
' Delegate to the private ADO recordset
PageSize = mrs.PageSize
End Property
Public Property Get RecordCount() As Long
' Delegate to the private ADO recordset
RecordCount = mrs.RecordCount
End Property
Public Property Let Sort(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Sort = RHS
End Property
Public Property Get Sort() As String
' Delegate to the private ADO recordset
Sort = mrs.Sort
End Property
Public Property Get State() As Long
' Delegate to the private ADO recordset
State = mrs.State
End Property
Listing 46
' PurchaseOrderIterator
Option Explicit
' Define ADODB.Field variables to bind to each
' column of the recordset
Private mfldID As Field
Private mfldAccountID As Field
Private mfldOrderDate As Field
Private mfldShippingHandling As Field
Private mfldTaxRate As Field
Private mfldTotal As Field
Private mfldShipToFirstName As Field
Private mfldShipToLastName As Field
Private mfldShipToAddressLine1 As Field
Private mfldShipToAddressLine2 As Field
Private mfldShipToCity As Field
Private mfldShipToState As Field
Private mfldShipToZip As Field
Private mfldShipToPhone As Field
Private mfldShipToEmail As Field
Private mrs As Recordset
Public Function Initialize(Optional ByVal strFilter As String = "") As Boolean
Dim objPurchaseOrderExec As Object
' To minimize network traffic, only send
' pre-validated requests to the executant
Set objPurchaseOrderExec = CreateObject("POExecutants.PurchaseOrderExec")
Set mrs = objPurchaseOrderExec.CreateRecordset(strFilter)
If Not mrs Is Nothing Then
' Bind to the columns of the recordset
BindToRecordsetFields
Initialize = True
End If
' Clean Up
Set objPurchaseOrderExec = Nothing
End Function
Public Property Get Item() As Object
Dim objPurchaseOrder As New PurchaseOrder
Dim rsLineItems As Recordset
Dim objLineItem As LineItem
Dim objInventory As Inventory
' Initialize the return value
Set Item = Nothing
' Configure the object to return
objPurchaseOrder.ID = mfldID
objPurchaseOrder.AccountID = mfldAccountID
objPurchaseOrder.OrderDate = mfldOrderDate
objPurchaseOrder.ShippingHandling = mfldShippingHandling
objPurchaseOrder.TaxRate = mfldTaxRate
objPurchaseOrder.Total = mfldTotal
objPurchaseOrder.ShipToFirstName = mfldShipToFirstName
objPurchaseOrder.ShipToLastName = mfldShipToLastName
objPurchaseOrder.ShipToAddressLine1 = mfldShipToAddressLine1
objPurchaseOrder.ShipToAddressLine2 = mfldShipToAddressLine2
objPurchaseOrder.ShipToCity = mfldShipToCity
objPurchaseOrder.ShipToState = mfldShipToState
objPurchaseOrder.ShipToZip = mfldShipToZip
objPurchaseOrder.ShipToPhone = mfldShipToPhone
objPurchaseOrder.ShipToEmail = mfldShipToEmail
' Iterate through the child recordset
Set rsLineItems = mrs("chapPurchaseOrderLineItems").Value
' Add each line item to the purchase order
Do While Not rsLineItems.EOF
Set objLineItem = New LineItem
objLineItem.ID = rsLineItems("ID")
objLineItem.PurchaseOrderID = rsLineItems("PurchaseOrderID")
objLineItem.Price = rsLineItems("Price")
objLineItem.Quantity = rsLineItems("Quantity")
'
Set objInventory = New Inventory
objInventory.ID = rsLineItems("Inventory.ID")
objInventory.Description = rsLineItems("Inventory.Description")
objInventory.Price = rsLineItems("Inventory.Price")
objInventory.QOH = rsLineItems("Inventory.QOH")
'
Set objLineItem.Item = objInventory
objPurchaseOrder.LineItems.Add objLineItem
rsLineItems.MoveNext
Loop
' Return the object
Set Item = objPurchaseOrder
' Clean up
Set objInventory = Nothing
Set objLineItem = Nothing
Set rsLineItems = Nothing
Set objPurchaseOrder = Nothing
End Property
Private Sub BindToRecordsetFields()
' Bind the module-level ADODB.Field variables
' to the columns of the recordset
If Not mrs Is Nothing Then
Set mfldID = mrs("ID")
Set mfldAccountID = mrs("Account.ID")
Set mfldOrderDate = mrs("OrderDate")
Set mfldShippingHandling = mrs("ShippingHandling")
Set mfldTaxRate = mrs("TaxRate")
Set mfldTotal = mrs("Total")
Set mfldShipToFirstName = mrs("ShipToFirstName")
Set mfldShipToLastName = mrs("ShipToLastName")
Set mfldShipToAddressLine1 = mrs("ShipToAddressLine1")
Set mfldShipToAddressLine2 = mrs("ShipToAddressLine2")
Set mfldShipToCity = mrs("ShipToCity")
Set mfldShipToState = mrs("ShipToState")
Set mfldShipToZip = mrs("ShipToZip")
Set mfldShipToPhone = mrs("ShipToPhone")
Set mfldShipToEmail = mrs("ShipToEmail")
End If
End Sub
Private Sub Class_Terminate()
' Release any module-level ADODB.Field references
Set mfldShipToEmail = Nothing
Set mfldShipToPhone = Nothing
Set mfldShipToZip = Nothing
Set mfldShipToState = Nothing
Set mfldShipToCity = Nothing
Set mfldShipToAddressLine2 = Nothing
Set mfldShipToAddressLine1 = Nothing
Set mfldShipToLastName = Nothing
Set mfldShipToFirstName = Nothing
Set mfldTotal = Nothing
Set mfldTaxRate = Nothing
Set mfldShippingHandling = Nothing
Set mfldOrderDate = Nothing
Set mfldAccountID = Nothing
Set mfldID = Nothing
' Release any outstanding Recordset references
Set mrs = Nothing
End Sub
Public Property Let AbsolutePage(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePage = RHS
End Property
Public Property Get AbsolutePage() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePage = mrs.AbsolutePage
End Property
Public Property Let AbsolutePosition(ByVal RHS As ADODB.PositionEnum)
' Delegate to the private ADO recordset
mrs.AbsolutePosition = RHS
End Property
Public Property Get AbsolutePosition() As ADODB.PositionEnum
' Delegate to the private ADO recordset
AbsolutePosition = mrs.AbsolutePosition
End Property
Public Property Get BOF() As Boolean
' Delegate to the private ADO recordset
BOF = mrs.BOF
End Property
Public Property Let Bookmark(ByVal RHS As Variant)
' Delegate to the private ADO recordset
mrs.Bookmark = RHS
End Property
Public Property Get Bookmark() As Variant
' Delegate to the private ADO recordset
Bookmark = mrs.Bookmark
End Property
Public Property Let CacheSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.CacheSize = RHS
End Property
Public Property Get CacheSize() As Long
' Delegate to the private ADO recordset
CacheSize = mrs.CacheSize
End Property
Public Function Clone(Optional LockType As ADODB.LockTypeEnum = adLockUnspecified) As ADODB.Recordset
' Delegate to the private ADO recordset
Set Clone = mrs.Clone(LockType)
End Function
Public Property Get EOF() As Boolean
' Delegate to the private ADO recordset
EOF = mrs.EOF
End Property
Public Property Let Filter(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Filter = RHS
End Property
Public Property Get Filter() As String
' Delegate to the private ADO recordset
Filter = mrs.Filter
End Property
Public Property Let MaxRecords(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.MaxRecords = RHS
End Property
Public Property Get MaxRecords() As Long
' Delegate to the private ADO recordset
MaxRecords = mrs.MaxRecords
End Property
Public Sub Move(ByVal NumRecords As Long, Optional Start As Variant = adBookmarkCurrent)
' Delegate to the private ADO recordset
mrs.Move NumRecords, Start
End Sub
Public Sub MoveFirst()
' Delegate to the private ADO recordset
mrs.MoveFirst
End Sub
Public Sub MoveLast()
' Delegate to the private ADO recordset
mrs.MoveLast
End Sub
Public Sub MoveNext()
' Delegate to the private ADO recordset
mrs.MoveNext
End Sub
Public Sub MovePrevious()
' Delegate to the private ADO recordset
mrs.MovePrevious
End Sub
Public Property Get PageCount() As Long
' Delegate to the private ADO recordset
PageCount = mrs.PageCount
End Property
Public Property Let PageSize(ByVal RHS As Long)
' Delegate to the private ADO recordset
mrs.PageSize = RHS
End Property
Public Property Get PageSize() As Long
' Delegate to the private ADO recordset
PageSize = mrs.PageSize
End Property
Public Property Get RecordCount() As Long
' Delegate to the private ADO recordset
RecordCount = mrs.RecordCount
End Property
Public Property Let Sort(ByVal RHS As String)
' Delegate to the private ADO recordset
mrs.Sort = RHS
End Property
Public Property Get Sort() As String
' Delegate to the private ADO recordset
Sort = mrs.Sort
End Property
Public Property Get State() As Long
' Delegate to the private ADO recordset
State = mrs.State
End Property
Listing 47
' InvalidProperties
Option Explicit
Private mcolInvalidProperties As New Collection
Public Property Get Count() As Variant
Count = mcolInvalidProperties.Count
End Property
Public Property Get Item(ByVal lngIndex As Long) As Long
' Return rule # (1 To Count)
Item = mcolInvalidProperties.Item(lngIndex)
End Property
Public Sub Track(ByVal lngRuleNumber As Long, ByVal blnInvalid As Boolean)
On Error GoTo ErrorHandler
If blnInvalid Then
' Add the invalid property to the collection
' if it doesn't already exist
mcolInvalidProperties.Add lngRuleNumber, "Key=" & CStr(lngRuleNumber)
Else
' Remove the invalid property from the
' collection if it exists
mcolInvalidProperties.Remove "Key=" & CStr(lngRuleNumber)
End If
ErrorHandler:
End Sub
Private Sub Class_ReadProperties(PropBag As PropertyBag)
Dim lngCount As Long
Dim lngIndex As Long
Dim lngRuleNumber As String
Set mcolInvalidProperties = New Collection
' Read the total number of items
lngCount = PropBag.ReadProperty("InvalidProperties", 0)
' VB Collections don't support persistence
' so we must read each collection item
' from the property bag manually
For lngIndex = 1 To lngCount
lngRuleNumber = PropBag.ReadProperty("InvalidProp" & CStr(lngIndex), 0)
Track lngRuleNumber, True
Next lngIndex
End Sub
Private Sub Class_Terminate()
Set mcolInvalidProperties = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
Dim lngCount As Long
Dim lngIndex As Long
Dim lngRuleNumber As Long
' Save the total number of items
lngCount = mcolInvalidProperties.Count
' VB Collections don't support persistence
' so we must write each collection item
' to the property bag manually
PropBag.WriteProperty "InvalidProperties", lngCount, 0
For lngIndex = 1 To lngCount
lngRuleNumber = mcolInvalidProperties.Item(lngIndex)
PropBag.WriteProperty "InvalidProp" & CStr(lngIndex), lngRuleNumber, 0
Next lngIndex
End Sub
Listing 48
' Account
Option Explicit
Implements IAccount
Private mobjInvalidProperties As New InvalidProperties
Private mlngID As Long
Private mstrFirstName As String
Private mstrLastName As String
Private mstrAddressLine1 As String
Private mstrAddressLine2 As String
Private mstrCity As String
Private mstrState As String
Private mstrZip As String
Private mstrPhone As String
Private mstrEmail As String
Private mcurBalance As Currency
Private mcurLimit As Currency
Public Function Save() As Boolean
Dim lngRuleNumber As Long
Dim rIAccountExec As IAccountExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
' Make sure the object is valid before
' attempting to save it
If mobjInvalidProperties.Count > 0 Then
' The object is invalid & the first
' invalid property is the error
lngRuleNumber = mobjInvalidProperties.Item(1)
Err.Raise vbObjectError + lngRuleNumber, LoadResString(IDS_PROJECTNAME), LoadResString(lngRuleNumber)
Else
Set rIAccountExec = CreateObject("POExecutants.AccountExec")
If mlngID = -1 Then
' Create a new Account
blnInvalid = Not rIAccountExec.Create(Me)
Else
' Modify an existing Account
blnInvalid = Not rIAccountExec.Modify(Me)
End If
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_SAVE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_SAVE)
Else
Save = True
End If
End If
Set rIAccountExec = Nothing
End Function
Public Function Destroy() As Boolean
Dim rIAccountExec As IAccountExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIAccountExec = CreateObject("POExecutants.AccountExec")
blnInvalid = Not rIAccountExec.Destroy(mlngID)
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_DESTROY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_DESTROY)
Else
Destroy = True
End If
' Clean Up
Set rIAccountExec = Nothing
End Function
Private Sub Class_Initialize()
' Initialize private members
mlngID = -1
' Track properties that are initially invalid but
' must become valid before the entire object can be
' deemed "Valid".
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_FIRSTNAME, True
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_LASTNAME, True
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_ADDRESS, True
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_CITY, True
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_STATE, True
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_ZIP, True
End Sub
Private Sub Class_ReadProperties(PropBag As PropertyBag)
' Load the saved state for the object
mlngID = PropBag.ReadProperty("ID", -1)
mstrFirstName = PropBag.ReadProperty("FirstName", "")
mstrLastName = PropBag.ReadProperty("LastName", "")
mstrAddressLine1 = PropBag.ReadProperty("AddressLine1", "")
mstrAddressLine2 = PropBag.ReadProperty("AddressLine2", "")
mstrCity = PropBag.ReadProperty("City", "")
mstrState = PropBag.ReadProperty("State", "")
mstrZip = PropBag.ReadProperty("Zip", "")
mstrPhone = PropBag.ReadProperty("Phone", "")
mstrEmail = PropBag.ReadProperty("Email", "")
mcurBalance = PropBag.ReadProperty("Balance", 0)
mcurLimit = PropBag.ReadProperty("Limit", 0)
' Load the invalid property information
Set mobjInvalidProperties = PropBag.ReadProperty("InvalidProperties", Nothing)
End Sub
Private Sub Class_Terminate()
' Clean up
Set mobjInvalidProperties = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
' Save the current state of the object
PropBag.WriteProperty "ID", mlngID, -1
PropBag.WriteProperty "FirstName", mstrFirstName, ""
PropBag.WriteProperty "LastName", mstrLastName, ""
PropBag.WriteProperty "AddressLine1", mstrAddressLine1, ""
PropBag.WriteProperty "AddressLine2", mstrAddressLine2, ""
PropBag.WriteProperty "City", mstrCity, ""
PropBag.WriteProperty "State", mstrState, ""
PropBag.WriteProperty "Zip", mstrZip, ""
PropBag.WriteProperty "Phone", mstrPhone, ""
PropBag.WriteProperty "Email", mstrEmail, ""
PropBag.WriteProperty "Balance", mcurBalance, 0
PropBag.WriteProperty "Limit", mcurLimit, 0
' Save the invalid property information
PropBag.WriteProperty "InvalidProperties", mobjInvalidProperties, Nothing
End Sub
Private Property Let IAccount_AddressLine1(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit AddressLine1 to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" And mstrAddressLine2 = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrAddressLine1 = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_ADDRESS, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_ADDRESS, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_ADDRESS)
End If
End Property
Private Property Get IAccount_AddressLine1() As String
IAccount_AddressLine1 = mstrAddressLine1
End Property
Private Property Let IAccount_AddressLine2(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit AddressLine2 to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" And mstrAddressLine1 = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrAddressLine2 = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_ADDRESS, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_ADDRESS, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_ADDRESS)
End If
End Property
Private Property Get IAccount_AddressLine2() As String
IAccount_AddressLine2 = mstrAddressLine2
End Property
Private Property Let IAccount_Balance(ByVal RHS As Currency)
' Perform any data validation that does not require
' access to the data services
mcurBalance = RHS
End Property
Private Property Get IAccount_Balance() As Currency
IAccount_Balance = mcurBalance
End Property
Private Property Let IAccount_City(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit City to 20 characters
RHS = Trim$(Left$(RHS, 20))
' City cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrCity = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_CITY, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_CITY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_CITY)
End If
End Property
Private Property Get IAccount_City() As String
IAccount_City = mstrCity
End Property
Public Function IncrementBalance(ByVal curAmount As Currency) As Boolean
Dim rIAccountExec As IAccountExec
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIAccountExec = CreateObject("POExecutants.AccountExec")
IncrementBalance = rIAccountExec.IncrementBalance(mlngID, curAmount)
' Clean Up
Set rIAccountExec = Nothing
End Function
Public Function DecrementBalance(ByVal curAmount As Currency) As Boolean
Dim rIAccountExec As IAccountExec
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIAccountExec = CreateObject("POExecutants.AccountExec")
DecrementBalance = rIAccountExec.DecrementBalance(mlngID, curAmount)
' Clean Up
Set rIAccountExec = Nothing
End Function
Private Property Let IAccount_Email(ByVal RHS As String)
' Perform any data validation that does not require
' access to the data services
' Limit Email to 20 characters
mstrEmail = Trim$(Left$(RHS, 20))
End Property
Private Property Get IAccount_Email() As String
IAccount_Email = mstrEmail
End Property
Private Property Let IAccount_FirstName(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit FirstName to 20 characters
RHS = Trim$(Left$(RHS, 20))
' FirstName cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrFirstName = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_FIRSTNAME, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_FIRSTNAME, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_FIRSTNAME)
End If
End Property
Private Property Get IAccount_FirstName() As String
IAccount_FirstName = mstrFirstName
End Property
Private Property Let IAccount_ID(ByVal RHS As Long)
' Perform any data validation that does not require
' access to the data services
mlngID = RHS
End Property
Private Property Get IAccount_ID() As Long
IAccount_ID = mlngID
End Property
Private Property Let IAccount_LastName(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit LastName to 40 characters
RHS = Trim$(Left$(RHS, 40))
' LastName cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrLastName = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_LASTNAME, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_LASTNAME, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_LASTNAME)
End If
End Property
Private Property Get IAccount_LastName() As String
IAccount_LastName = mstrLastName
End Property
Private Property Let IAccount_Limit(ByVal RHS As Currency)
' Perform any data validation that does not require
' access to the data services
mcurLimit = RHS
End Property
Private Property Get IAccount_Limit() As Currency
IAccount_Limit = mcurLimit
End Property
Private Function IAccount_MarshalToPropertyBag(strKey As String) As Byte()
Dim objPropertyBag As New PropertyBag
' Return the key that identifies the
' object state information ByRef
strKey = "AccountState"
' Marshal this object instance to the property bag
objPropertyBag.WriteProperty strKey, Me, Nothing
' Return the contents of the property bag
' which can be assigned to another property bag
' and accessed via 'strKey' to recreate the object
IAccount_MarshalToPropertyBag = objPropertyBag.Contents
Set objPropertyBag = Nothing
End Function
Private Property Let IAccount_Phone(ByVal RHS As String)
' Perform any data validation that does not require
' access to the data services
' Limit Phone to 12 characters
mstrPhone = Trim$(Left$(RHS, 12))
End Property
Private Property Get IAccount_Phone() As String
IAccount_Phone = mstrPhone
End Property
Private Property Let IAccount_State(ByVal RHS As String)
Dim intCharacterCode As Integer
Dim intPos As Integer
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' State must be 2 alpha characters
If Len(RHS) = 2 Then
blnInvalid = False
For intPos = 1 To 2
intCharacterCode = Asc(Mid$(RHS, intPos, 1))
If intCharacterCode < 65 Or intCharacterCode > 122 Then
blnInvalid = True
Exit For
End If
Next intPos
' If the new value is valid then save it
If Not blnInvalid Then
mstrState = RHS
End If
Else
blnInvalid = True
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_STATE, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_STATE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_STATE)
End If
End Property
Private Property Get IAccount_State() As String
IAccount_State = mstrState
End Property
Private Property Get IAccount_Valid() As Boolean
' The entire object cannot be valid unless
' all of its properties are valid
IAccount_Valid = (mobjInvalidProperties.Count = 0)
End Property
Private Property Let IAccount_Zip(ByVal RHS As String)
Dim intCharacterCode As Integer
Dim intPos As Integer
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Zip must be 5 numeric characters
If Len(RHS) = 5 Then
blnInvalid = False
For intPos = 1 To 5
intCharacterCode = Asc(Mid$(RHS, intPos, 1))
If intCharacterCode < 48 Or intCharacterCode > 57 Then
blnInvalid = True
Exit For
End If
Next intPos
' If the new value is valid then save it
If Not blnInvalid Then
mstrZip = RHS
End If
Else
blnInvalid = True
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_ACCOUNT_ZIP, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_ACCOUNT_ZIP, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_ACCOUNT_ZIP)
End If
End Property
Private Property Get IAccount_Zip() As String
IAccount_Zip = mstrZip
End Property
Public Property Get AddressLine1() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
AddressLine1 = IAccount_AddressLine1
End Property
Public Property Let AddressLine1(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_AddressLine1 = strNewValue
End Property
Public Property Get AddressLine2() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
AddressLine2 = IAccount_AddressLine2
End Property
Public Property Let AddressLine2(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_AddressLine2 = strNewValue
End Property
Public Property Get Balance() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Balance = IAccount_Balance
End Property
Public Property Let Balance(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_Balance = curNewValue
End Property
Public Property Get City() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
City = IAccount_City
End Property
Public Property Let City(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_City = strNewValue
End Property
Public Property Get State() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
State = IAccount_State
End Property
Public Property Let State(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_State = strNewValue
End Property
Public Property Get Zip() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
Zip = IAccount_Zip
End Property
Public Property Let Zip(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_Zip = strNewValue
End Property
Public Property Get Email() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
Email = IAccount_Email
End Property
Public Property Let Email(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_Email = strNewValue
End Property
Public Property Get Phone() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
Phone = IAccount_Phone
End Property
Public Property Let Phone(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_Phone = strNewValue
End Property
Public Property Get FirstName() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
FirstName = IAccount_FirstName
End Property
Public Property Let FirstName(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_FirstName = strNewValue
End Property
Public Property Get LastName() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
LastName = IAccount_LastName
End Property
Public Property Let LastName(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_LastName = strNewValue
End Property
Public Property Get ID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
ID = IAccount_ID
End Property
Public Property Let ID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_ID = lngNewValue
End Property
Public Property Get Limit() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Limit = IAccount_Limit
End Property
Public Property Let Limit(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IAccount_Limit = curNewValue
End Property
Public Function MarshalToPropertyBag(strKey As String) As Byte()
' Delegate the default interface implementation
' to the appropriate interface implementation
MarshalToPropertyBag = IAccount_MarshalToPropertyBag(strKey)
End Function
Public Property Get Valid() As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Valid = IAccount_Valid
End Property
Listing 49
' Inventory
Option Explicit
Implements IInventory
Private mobjInvalidProperties As New InvalidProperties
Private mlngID As Long
Private mstrDescription As String
Private mcurPrice As Currency
Private mlngQOH As Long
Private Function IncrementQOH(ByVal lngQuantity As Long) As Boolean
Dim rIInventoryExec As IInventoryExec
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIInventoryExec = CreateObject("POExecutants.InventoryExec")
IncrementQOH = rIInventoryExec.IncrementQOH(mlngID, lngQuantity)
' Clean Up
Set rIInventoryExec = Nothing
End Function
Private Function DecrementQOH(ByVal lngQuantity As Long) As Boolean
Dim rIInventoryExec As IInventoryExec
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIInventoryExec = CreateObject("POExecutants.InventoryExec")
DecrementQOH = rIInventoryExec.DecrementQOH(mlngID, lngQuantity)
' Clean Up
Set rIInventoryExec = Nothing
End Function
Public Function Save() As Boolean
Dim lngRuleNumber As Long
Dim rIInventoryExec As IInventoryExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
' Make sure the object is valid before
' attempting to save it
If mobjInvalidProperties.Count > 0 Then
' The object is invalid & the first
' invalid property is the error
lngRuleNumber = mobjInvalidProperties.Item(1)
Err.Raise vbObjectError + lngRuleNumber, LoadResString(IDS_PROJECTNAME), LoadResString(lngRuleNumber)
Else
Set rIInventoryExec = CreateObject("POExecutants.InventoryExec")
If mlngID = -1 Then
' Create a new Inventory item
blnInvalid = Not rIInventoryExec.Create(Me)
Else
' Modify an existing Inventory item
blnInvalid = Not rIInventoryExec.Modify(Me)
End If
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_INVENTORY_SAVE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_INVENTORY_SAVE)
Else
Save = True
End If
End If
Set rIInventoryExec = Nothing
End Function
Public Function Destroy() As Boolean
Dim rIInventoryExec As IInventoryExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIInventoryExec = CreateObject("POExecutants.InventoryExec")
blnInvalid = Not rIInventoryExec.Destroy(mlngID)
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_INVENTORY_DESTROY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_INVENTORY_DESTROY)
Else
Destroy = True
End If
' Clean Up
Set rIInventoryExec = Nothing
End Function
Private Sub Class_Initialize()
' Initialize private members
mlngID = -1
' Track properties that are initially invalid but
' must become valid before the entire object can be
' deemed "Valid".
mobjInvalidProperties.Track IDS_INVALID_INVENTORY_DESCRIPTION, True
End Sub
Private Sub Class_ReadProperties(PropBag As PropertyBag)
' Load the saved state for the object
mlngID = PropBag.ReadProperty("ID", -1)
mstrDescription = PropBag.ReadProperty("Description", "")
mcurPrice = PropBag.ReadProperty("Price", 0)
mlngQOH = PropBag.ReadProperty("QOH", 0)
' Load the invalid property information
Set mobjInvalidProperties = PropBag.ReadProperty("InvalidProperties", Nothing)
End Sub
Private Sub Class_Terminate()
' Clean up
Set mobjInvalidProperties = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
' Save the current state of the object
PropBag.WriteProperty "ID", mlngID, -1
PropBag.WriteProperty "Description", mstrDescription, ""
PropBag.WriteProperty "Price", mcurPrice, 0
PropBag.WriteProperty "QOH", mlngQOH, 0
' Save the invalid property information
PropBag.WriteProperty "InvalidProperties", mobjInvalidProperties, Nothing
End Sub
Private Property Let IInventory_Description(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit Description to 50 characters
RHS = Trim$(Left$(RHS, 50))
' Description cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrDescription = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_INVENTORY_DESCRIPTION, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_INVENTORY_DESCRIPTION, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_INVENTORY_DESCRIPTION)
End If
End Property
Private Property Get IInventory_Description() As String
IInventory_Description = mstrDescription
End Property
Private Property Let IInventory_ID(ByVal RHS As Long)
' Perform any data validation that does not require
' access to the data services
mlngID = RHS
End Property
Private Property Get IInventory_ID() As Long
IInventory_ID = mlngID
End Property
Private Function IInventory_MarshalToPropertyBag(strKey As String) As Byte()
Dim objPropertyBag As New PropertyBag
' Return the key that identifies the
' object state information ByRef
strKey = "InventoryState"
' Marshal this object instance to the property bag
objPropertyBag.WriteProperty strKey, Me, Nothing
' Return the contents of the property bag
' which can be assigned to another property bag
' and accessed via 'strKey' to recreate the object
IInventory_MarshalToPropertyBag = objPropertyBag.Contents
Set objPropertyBag = Nothing
End Function
Public Function MarshalToPropertyBag(strKey As String) As Byte()
' Delegate the default interface implementation
' to the appropriate interface implementation
MarshalToPropertyBag = IInventory_MarshalToPropertyBag(strKey)
End Function
Private Property Let IInventory_Price(ByVal RHS As Currency)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Price cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
mcurPrice = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_INVENTORY_PRICE, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_INVENTORY_PRICE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_INVENTORY_PRICE)
End If
End Property
Private Property Get IInventory_Price() As Currency
IInventory_Price = mcurPrice
End Property
Private Property Let IInventory_QOH(ByVal RHS As Long)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Quantity On Hand cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
mlngQOH = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_INVENTORY_QOH, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_INVENTORY_QOH, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_INVENTORY_QOH)
End If
End Property
Private Property Get IInventory_QOH() As Long
IInventory_QOH = mlngQOH
End Property
Public Property Get ID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
ID = IInventory_ID
End Property
Public Property Let ID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
IInventory_ID = lngNewValue
End Property
Public Property Get Description() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
Description = IInventory_Description
End Property
Public Property Let Description(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IInventory_Description = strNewValue
End Property
Public Property Get Price() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Price = IInventory_Price
End Property
Public Property Let Price(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IInventory_Price = curNewValue
End Property
Public Property Get QOH() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
QOH = IInventory_QOH
End Property
Public Property Get Valid() As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Valid = IInventory_Valid
End Property
Public Property Let QOH(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
IInventory_QOH = lngNewValue
End Property
Private Property Get IInventory_Valid() As Boolean
' The entire object cannot be valid unless
' all of its properties are valid
IInventory_Valid = (mobjInvalidProperties.Count = 0)
End Property
Listing 50
' LineItem
Option Explicit
Implements ILineItem
Private mobjInvalidProperties As New InvalidProperties
Private mlngID As Long
Private mlngPurchaseOrderID As Long
Private mrIInventory As IInventory
Private mcurPrice As Currency
Private mlngQuantity As Long
Public Function Save() As Boolean
Dim lngRuleNumber As Long
Dim rILineItemExec As ILineItemExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
' Make sure the object is valid before
' attempting to save it
If mobjInvalidProperties.Count > 0 Then
' The object is invalid & the first
' invalid property is the error
lngRuleNumber = mobjInvalidProperties.Item(1)
Err.Raise vbObjectError + lngRuleNumber, LoadResString(IDS_PROJECTNAME), LoadResString(lngRuleNumber)
Else
Set rILineItemExec = CreateObject("POExecutants.LineItemExec")
If mlngID = -1 Then
' Create a new LineItem
blnInvalid = Not rILineItemExec.Create(Me)
Else
' Modify an existing LineItem
blnInvalid = Not rILineItemExec.Modify(Me)
End If
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_LINEITEM_SAVE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_LINEITEM_SAVE)
Else
Save = True
End If
End If
Set rILineItemExec = Nothing
End Function
Public Function Destroy() As Boolean
Dim rILineItemExec As ILineItemExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rILineItemExec = CreateObject("POExecutants.LineItemExec")
blnInvalid = Not rILineItemExec.Destroy(mlngID)
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_LINEITEM_DESTROY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_LINEITEM_DESTROY)
Else
Destroy = True
End If
' Clean Up
Set rILineItemExec = Nothing
End Function
Public Property Get ID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
ID = ILineItem_ID
End Property
Public Property Let ID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
ILineItem_ID = lngNewValue
End Property
Public Property Get Valid() As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Valid = ILineItem_Valid
End Property
Public Property Get Price() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Price = ILineItem_Price
End Property
Public Property Let Price(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
ILineItem_Price = curNewValue
End Property
Private Sub Class_Initialize()
' Initialize private members
mlngID = -1
mlngPurchaseOrderID = -1
' Track properties that are initially invalid but
' must become valid before the entire object can be
' deemed "Valid".
mobjInvalidProperties.Track IDS_INVALID_LINEITEM_ITEM, True
End Sub
Private Sub Class_ReadProperties(PropBag As PropertyBag)
' Load the saved state for the object
mlngID = PropBag.ReadProperty("ID", -1)
mlngPurchaseOrderID = PropBag.ReadProperty("PurchaseOrderID", 0)
Set mrIInventory = PropBag.ReadProperty("InventoryItem", Nothing)
mcurPrice = PropBag.ReadProperty("Price", 0)
mlngQuantity = PropBag.ReadProperty("Quantity", 0)
' Load the invalid property information
Set mobjInvalidProperties = PropBag.ReadProperty("InvalidProperties", Nothing)
End Sub
Public Function MarshalToPropertyBag(strKey As String) As Byte()
' Delegate the default interface implementation
' to the appropriate interface implementation
MarshalToPropertyBag = ILineItem_MarshalToPropertyBag(strKey)
End Function
Private Sub Class_Terminate()
' Clean up
Set mrIInventory = Nothing
Set mobjInvalidProperties = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
' Save the current state of the object
PropBag.WriteProperty "ID", mlngID, -1
PropBag.WriteProperty "PurchaseOrderID", mlngPurchaseOrderID, 0
PropBag.WriteProperty "InventoryItem", mrIInventory, Nothing
PropBag.WriteProperty "Price", mcurPrice, 0
PropBag.WriteProperty "Quantity", mlngQuantity, 0
' Save the invalid property information
PropBag.WriteProperty "InvalidProperties", mobjInvalidProperties, Nothing
End Sub
Private Property Let ILineItem_ID(ByVal RHS As Long)
' Perform any data validation that does not require
' access to the data services
' Update the property with the new value
mlngID = RHS
End Property
Private Property Get ILineItem_ID() As Long
ILineItem_ID = mlngID
End Property
Private Property Get ILineItem_Item() As POInterfaces.IInventory
Set ILineItem_Item = mrIInventory
End Property
Private Property Set ILineItem_Item(ByVal RHS As POInterfaces.IInventory)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Item must be a valid reference
If RHS Is Nothing Then
blnInvalid = True
Else
blnInvalid = False
' Update the property with the new value
Set mrIInventory = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_LINEITEM_ITEM, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_LINEITEM_ITEM, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_LINEITEM_ITEM)
End If
End Property
Private Function ILineItem_MarshalToPropertyBag(strKey As String) As Byte()
Dim objPropertyBag As New PropertyBag
' Return the key that identifies the
' object state information ByRef
strKey = "LineItemState"
' Marshal this object instance to the property bag
objPropertyBag.WriteProperty strKey, Me, Nothing
' Return the contents of the property bag
' which can be assigned to another property bag
' and accessed via 'strKey' to recreate the object
ILineItem_MarshalToPropertyBag = objPropertyBag.Contents
Set objPropertyBag = Nothing
End Function
Private Property Let ILineItem_Price(ByVal RHS As Currency)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Price cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
' Update the property with the new value
mcurPrice = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_LINEITEM_PRICE, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_LINEITEM_PRICE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_LINEITEM_PRICE)
End If
End Property
Private Property Get ILineItem_Price() As Currency
ILineItem_Price = mcurPrice
End Property
Private Property Get ILineItem_PurchaseOrderID() As Long
ILineItem_PurchaseOrderID = mlngPurchaseOrderID
End Property
Private Property Let ILineItem_PurchaseOrderID(ByVal RHS As Long)
' Perform any data validation that does not require
' access to the data services
' Update the property with the new value
mlngPurchaseOrderID = RHS
End Property
Private Property Let ILineItem_Quantity(ByVal RHS As Long)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Quantity cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
' Update the property with the new value
mlngQuantity = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_LINEITEM_QUANTITY, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_LINEITEM_QUANTITY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_LINEITEM_QUANTITY)
End If
End Property
Private Property Get ILineItem_Quantity() As Long
ILineItem_Quantity = mlngQuantity
End Property
Public Property Get Quantity() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
Quantity = ILineItem_Quantity
End Property
Public Property Let Quantity(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
ILineItem_Quantity = lngNewValue
End Property
Public Property Get PurchaseOrderID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
PurchaseOrderID = ILineItem_PurchaseOrderID
End Property
Public Property Let PurchaseOrderID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
ILineItem_PurchaseOrderID = lngNewValue
End Property
Public Property Get Item() As Inventory
' Delegate the default interface implementation
' to the appropriate interface implementation
Set Item = ILineItem_Item
End Property
Public Property Set Item(robjInventory As Inventory)
' Delegate the default interface implementation
' to the appropriate interface implementation
Set ILineItem_Item = robjInventory
End Property
Private Property Get ILineItem_Valid() As Boolean
' The entire object cannot be valid unless
' all of its properties are valid
ILineItem_Valid = (mobjInvalidProperties.Count = 0)
End Property
Listing 51
' LineItems
Option Explicit
Implements ILineItems
Private mcolLineItems As New Collection
Public Property Get Count() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
Count = ILineItems_Count
End Property
Private Sub Class_ReadProperties(PropBag As PropertyBag)
Dim lngCount As Long
Dim lngNextItem As Long
Dim rILineItem As ILineItem
' Get the property values
' out of the property bag
lngCount = PropBag.ReadProperty("Count", 0)
' Load each LineItem object
For lngNextItem = 1 To lngCount
Set rILineItem = PropBag.ReadProperty("LineItem" & CStr(lngNextItem), Nothing)
' Add the object to the internal collection
' using the interface implementation
ILineItems_Add rILineItem
Next lngNextItem
Set rILineItem = Nothing
End Sub
Private Sub Class_Terminate()
Dim lngLineItem As Long
If Not mcolLineItems Is Nothing Then
' Delete any remaining line items
For lngLineItem = 1 To mcolLineItems.Count
mcolLineItems.Remove 1
Next lngLineItem
End If
Set mcolLineItems = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
Dim lngCount As Long
Dim lngNextItem As Long
Dim rILineItem As ILineItem
' Put the property values
' into the property bag
lngCount = ILineItems_Count
' Save each LineItem object
For lngNextItem = 1 To lngCount
Set rILineItem = ILineItems_Item(lngNextItem)
PropBag.WriteProperty "LineItem" & CStr(lngNextItem), rILineItem, Nothing
Next lngNextItem
PropBag.WriteProperty "Count", lngCount, 0
Set rILineItem = Nothing
End Sub
Private Function ILineItems_Add(rILineItem As POInterfaces.ILineItem) As Boolean
' Perform non-dabatase data validation
' Implement non-database specific business logic
If Not rILineItem Is Nothing Then
mcolLineItems.Add rILineItem
ILineItems_Add = True
End If
End Function
Public Function Add(vntILineItem As Variant) As Boolean
Dim rILineItem As ILineItem
' Cast the generic object reference
' into a specific object type
If VarType(vntILineItem) = vbObject Then
Set rILineItem = vntILineItem
' Delegate the default interface implementation
' to the appropriate interface implementation
Add = ILineItems_Add(rILineItem)
End If
Set rILineItem = Nothing
End Function
Public Function Item(ByVal lngPosKey As Long) As LineItem
' Delegate the default interface implementation
' to the appropriate interface implementation
Set Item = ILineItems_Item(lngPosKey)
End Function
Public Function Remove(ByVal lngPosKey As Long) As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Remove = ILineItems_Remove(lngPosKey)
End Function
Private Property Get ILineItems_Count() As Long
' Perform non-dabatase data validation
' Implement non-database specific business logic
ILineItems_Count = mcolLineItems.Count
End Property
Private Function ILineItems_Item(ByVal lngPosKey As Long) As POInterfaces.ILineItem
' Perform non-dabatase data validation
' Implement non-database specific business logic
If lngPosKey < 1 Or lngPosKey > mcolLineItems.Count Then
Set ILineItems_Item = Nothing
Else
Set ILineItems_Item = mcolLineItems.Item(lngPosKey)
End If
End Function
Private Function ILineItems_Remove(ByVal lngPosKey As Long) As Boolean
' Perform non-dabatase data validation
' Implement non-database specific business logic
If lngPosKey >= 1 And lngPosKey <= mcolLineItems.Count Then
mcolLineItems.Remove lngPosKey
ILineItems_Remove = True
End If
End Function
Listing 52
' PurchaseOrder
Option Explicit
Implements IPurchaseOrder
Private mobjInvalidProperties As New InvalidProperties
Private mlngID As Long
Private mlngAccountID As Long
Private mobjLineItems As New LineItems
Private mdatOrderDate As Date
Private mcurShippingHandling As Currency
Private mdblTaxRate As Double
Private mcurTotal As Currency
Private mstrShipToFirstName As String
Private mstrShipToLastName As String
Private mstrShipToAddressLine1 As String
Private mstrShipToAddressLine2 As String
Private mstrShipToCity As String
Private mstrShipToState As String
Private mstrShipToZip As String
Private mstrShipToPhone As String
Private mstrShipToEmail As String
Public Function Cancel() As Boolean
Dim rIPurchaseOrderExec As IPurchaseOrderExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIPurchaseOrderExec = CreateObject("POExecutants.PurchaseOrderExec")
blnInvalid = Not rIPurchaseOrderExec.Cancel(mlngID)
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_CANCEL, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_CANCEL)
Else
Cancel = True
End If
' Clean Up
Set rIPurchaseOrderExec = Nothing
End Function
Public Function Destroy() As Boolean
Dim rIPurchaseOrderExec As IPurchaseOrderExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
Set rIPurchaseOrderExec = CreateObject("POExecutants.PurchaseOrderExec")
blnInvalid = Not rIPurchaseOrderExec.Destroy(mlngID)
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_DESTROY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_DESTROY)
Else
Destroy = True
End If
' Clean Up
Set rIPurchaseOrderExec = Nothing
End Function
Public Function Save() As Boolean
Dim lngRuleNumber As Long
Dim rIPurchaseOrderExec As IPurchaseOrderExec
Dim blnInvalid As Boolean
' To minimize network traffic, only send
' pre-validated requests to the executant
' Make sure the object is valid before
' attempting to save it
If mobjInvalidProperties.Count > 0 Then
' The object is invalid & the first
' invalid property is the error
lngRuleNumber = mobjInvalidProperties.Item(1)
Err.Raise vbObjectError + lngRuleNumber, LoadResString(IDS_PROJECTNAME), LoadResString(lngRuleNumber)
Else
Set rIPurchaseOrderExec = CreateObject("POExecutants.PurchaseOrderExec")
If mlngID = -1 Then
' Create a new PurchaseOrder
blnInvalid = Not rIPurchaseOrderExec.Create(Me)
Else
' Modify an existing PurchaseOrder
blnInvalid = Not rIPurchaseOrderExec.Modify(Me)
End If
If blnInvalid Then
' Notify the client of any error
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SAVE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SAVE)
Else
Save = True
End If
End If
Set rIPurchaseOrderExec = Nothing
End Function
Public Property Get Tax() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Tax = IPurchaseOrder_Tax
End Property
Public Property Let Tax(ByVal curTax As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_Tax = curTax
End Property
Public Property Get Valid() As Boolean
' Delegate the default interface implementation
' to the appropriate interface implementation
Valid = IPurchaseOrder_Valid
End Property
Private Sub Class_Initialize()
' Initialize private members
mlngID = -1
mlngAccountID = -1
mdatOrderDate = Date
' Shipping and Handling is fixed at $20.00
mcurShippingHandling = 20#
' The tax rate is 8.6%
mdblTaxRate = 0.086
' Track properties that are initially invalid but
' must become valid before the entire object can be
' deemed "Valid".
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_ACCOUNTID, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOFIRSTNAME, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOLASTNAME, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOCITY, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOSTATE, True
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOZIP, True
End Sub
Private Sub Class_ReadProperties(PropBag As PropertyBag)
' Load the saved state of the object
mlngID = PropBag.ReadProperty("ID", -1)
mlngAccountID = PropBag.ReadProperty("AccountID", -1)
mdatOrderDate = PropBag.ReadProperty("OrderDate", Date)
mcurShippingHandling = PropBag.ReadProperty("ShippingHandling", 0)
mdblTaxRate = PropBag.ReadProperty("TaxRate", 0)
mcurTotal = PropBag.ReadProperty("Total", 0)
mstrShipToFirstName = PropBag.ReadProperty("ShipToFirstName", "")
mstrShipToLastName = PropBag.ReadProperty("ShipToLastName", "")
mstrShipToAddressLine1 = PropBag.ReadProperty("ShipToAddressLine1", "")
mstrShipToAddressLine2 = PropBag.ReadProperty("ShipToAddressLine2", "")
mstrShipToCity = PropBag.ReadProperty("ShipToCity", "")
mstrShipToState = PropBag.ReadProperty("ShipToState", "")
mstrShipToZip = PropBag.ReadProperty("ShipToZip", "")
mstrShipToPhone = PropBag.ReadProperty("ShipToPhone", "")
mstrShipToEmail = PropBag.ReadProperty("ShipToEmail", "")
Set mobjLineItems = PropBag.ReadProperty("LineItems", Nothing)
' Load the invalid property information
Set mobjInvalidProperties = PropBag.ReadProperty("InvalidProperties", Nothing)
End Sub
Private Sub Class_Terminate()
' Clean up
Set mobjLineItems = Nothing
Set mobjInvalidProperties = Nothing
End Sub
Private Sub Class_WriteProperties(PropBag As PropertyBag)
' Save the current state of the object
PropBag.WriteProperty "ID", mlngID, -1
PropBag.WriteProperty "AccountID", mlngAccountID, -1
PropBag.WriteProperty "OrderDate", mdatOrderDate, Date
PropBag.WriteProperty "ShippingHandling", mcurShippingHandling, 0
PropBag.WriteProperty "TaxRate", mdblTaxRate, 0
PropBag.WriteProperty "Total", mcurTotal, 0
PropBag.WriteProperty "ShipToFirstName", mstrShipToFirstName, ""
PropBag.WriteProperty "ShipToLastName", mstrShipToLastName, ""
PropBag.WriteProperty "ShipToAddressLine1", mstrShipToAddressLine1, ""
PropBag.WriteProperty "ShipToAddressLine2", mstrShipToAddressLine2, ""
PropBag.WriteProperty "ShipToCity", mstrShipToCity, ""
PropBag.WriteProperty "ShipToState", mstrShipToState, ""
PropBag.WriteProperty "ShipToZip", mstrShipToZip, ""
PropBag.WriteProperty "ShipToPhone", mstrShipToPhone, ""
PropBag.WriteProperty "ShipToEmail", mstrShipToEmail, ""
PropBag.WriteProperty "LineItems", mobjLineItems, Nothing
' Save the invalid property information
PropBag.WriteProperty "InvalidProperties", mobjInvalidProperties, Nothing
End Sub
Private Property Let IPurchaseOrder_AccountID(ByVal RHS As Long)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' AccountID must be greater than 0
If RHS < 1 Then
blnInvalid = True
Else
blnInvalid = False
mlngAccountID = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_ACCOUNTID, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_ACCOUNTID, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_ACCOUNTID)
End If
End Property
Private Property Get IPurchaseOrder_AccountID() As Long
IPurchaseOrder_AccountID = mlngAccountID
End Property
Private Property Let IPurchaseOrder_ID(ByVal RHS As Long)
' Perform any data validation that does not require
' access to the data services
mlngID = RHS
End Property
Private Property Get IPurchaseOrder_ID() As Long
IPurchaseOrder_ID = mlngID
End Property
Private Property Get IPurchaseOrder_LineItems() As POInterfaces.ILineItems
Set IPurchaseOrder_LineItems = mobjLineItems
End Property
Private Function IPurchaseOrder_MarshalToPropertyBag(strKey As String) As Byte()
Dim objPropertyBag As New PropertyBag
' Return the key that identifies the
' object state information ByRef
strKey = "PurchaseOrderState"
' Marshal this object instance to the property bag
objPropertyBag.WriteProperty strKey, Me, Nothing
' Return the contents of the property bag
' which can be assigned to another property bag
' and accessed via 'strKey' to recreate the object
IPurchaseOrder_MarshalToPropertyBag = objPropertyBag.Contents
Set objPropertyBag = Nothing
End Function
Public Function MarshalToPropertyBag(strKey As String) As Byte()
' Delegate the default interface implementation
' to the appropriate interface implementation
MarshalToPropertyBag = IPurchaseOrder_MarshalToPropertyBag(strKey)
End Function
Private Property Let IPurchaseOrder_OrderDate(ByVal RHS As Date)
' Perform any data validation that does not require
' access to the data services
mdatOrderDate = RHS
End Property
Private Property Get IPurchaseOrder_OrderDate() As Date
IPurchaseOrder_OrderDate = mdatOrderDate
End Property
Private Property Let IPurchaseOrder_ShippingHandling(ByVal RHS As Currency)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' ShippingHandling cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
mcurShippingHandling = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPPINGHANDLING, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPPINGHANDLING, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPPINGHANDLING)
End If
End Property
Private Property Get IPurchaseOrder_ShippingHandling() As Currency
IPurchaseOrder_ShippingHandling = mcurShippingHandling
End Property
Private Property Let IPurchaseOrder_ShipToAddressLine1(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit ShipToAddressLine1 to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" And mstrShipToAddressLine2 = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrShipToAddressLine1 = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS)
End If
End Property
Private Property Get IPurchaseOrder_ShipToAddressLine1() As String
IPurchaseOrder_ShipToAddressLine1 = mstrShipToAddressLine1
End Property
Private Property Get IPurchaseOrder_ShipToAddressLine2() As String
IPurchaseOrder_ShipToAddressLine2 = mstrShipToAddressLine2
End Property
Private Property Let IPurchaseOrder_ShipToAddressLine2(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit ShipToAddressLine2 to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" And mstrShipToAddressLine1 = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrShipToAddressLine2 = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS)
End If
End Property
Private Property Get IPurchaseOrder_ShipToCity() As String
IPurchaseOrder_ShipToCity = mstrShipToCity
End Property
Private Property Let IPurchaseOrder_ShipToCity(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit ShipToCity to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrShipToCity = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOCITY, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOCITY, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOCITY)
End If
End Property
Private Property Get IPurchaseOrder_ShipToEmail() As String
IPurchaseOrder_ShipToEmail = mstrShipToEmail
End Property
Private Property Let IPurchaseOrder_ShipToEmail(ByVal RHS As String)
' Perform any data validation that does not require
' access to the data services
' Limit ShipToEmail to 20 characters
mstrShipToEmail = Trim$(Left$(RHS, 20))
End Property
Private Property Get IPurchaseOrder_ShipToFirstName() As String
IPurchaseOrder_ShipToFirstName = mstrShipToFirstName
End Property
Private Property Let IPurchaseOrder_ShipToFirstName(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit ShipToFirstName to 20 characters
RHS = Trim$(Left$(RHS, 20))
' Address cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrShipToFirstName = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOFIRSTNAME, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOFIRSTNAME, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOFIRSTNAME)
End If
End Property
Private Property Get IPurchaseOrder_ShipToLastName() As String
IPurchaseOrder_ShipToLastName = mstrShipToLastName
End Property
Private Property Let IPurchaseOrder_ShipToLastName(ByVal RHS As String)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Limit ShipToLastName to 40 characters
RHS = Trim$(Left$(RHS, 40))
' ShipToLastName cannot be blank
If RHS = "" Then
blnInvalid = True
Else
blnInvalid = False
mstrShipToLastName = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOLASTNAME, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOLASTNAME, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOLASTNAME)
End If
End Property
Private Property Get IPurchaseOrder_ShipToPhone() As String
IPurchaseOrder_ShipToPhone = mstrShipToPhone
End Property
Private Property Let IPurchaseOrder_ShipToPhone(ByVal RHS As String)
' Perform any data validation that does not require
' access to the data services
' Limit ShipToPhone to 12 characters
mstrShipToPhone = Trim$(Left$(RHS, 12))
End Property
Private Property Get IPurchaseOrder_ShipToState() As String
IPurchaseOrder_ShipToState = mstrShipToState
End Property
Private Property Let IPurchaseOrder_ShipToState(ByVal RHS As String)
Dim intCharacterCode As Integer
Dim intPos As Integer
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' ShipToState must be 2 alpha characters
If Len(RHS) = 2 Then
blnInvalid = False
For intPos = 1 To 2
intCharacterCode = Asc(Mid$(RHS, intPos, 1))
If intCharacterCode < 65 Or intCharacterCode > 122 Then
blnInvalid = True
Exit For
End If
Next intPos
' If the new value is valid then save it
If Not blnInvalid Then
mstrShipToState = RHS
End If
Else
blnInvalid = True
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOSTATE, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOSTATE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOSTATE)
End If
End Property
Private Property Get IPurchaseOrder_ShipToZip() As String
IPurchaseOrder_ShipToZip = mstrShipToZip
End Property
Private Property Let IPurchaseOrder_ShipToZip(ByVal RHS As String)
Dim intCharacterCode As Integer
Dim intPos As Integer
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' ShipToZip must be 5 numeric characters
If Len(RHS) = 5 Then
blnInvalid = False
For intPos = 1 To 5
intCharacterCode = Asc(Mid$(RHS, intPos, 1))
If intCharacterCode < 48 Or intCharacterCode > 57 Then
blnInvalid = True
Exit For
End If
Next intPos
' If the new value is valid then save it
If Not blnInvalid Then
mstrShipToZip = RHS
End If
Else
blnInvalid = True
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_SHIPTOZIP, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_SHIPTOZIP, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_SHIPTOZIP)
End If
End Property
Private Property Get IPurchaseOrder_SubTotal() As Currency
Dim rILineItem As ILineItem
Dim lngItem As Long
Dim curSubTotal As Currency
For lngItem = 1 To mobjLineItems.Count
Set rILineItem = mobjLineItems.Item(lngItem)
curSubTotal = curSubTotal + (rILineItem.Price * rILineItem.Quantity)
Next lngItem
IPurchaseOrder_SubTotal = curSubTotal
Set rILineItem = Nothing
End Property
Private Property Let IPurchaseOrder_SubTotal(ByVal RHS As Currency)
' Perform any data validation that does not require
' access to the data services
' Property is R/O
Err.Raise 383
End Property
Private Property Get IPurchaseOrder_Tax() As Currency
' Don't charge tax unless there are
' items actually being purchased
If mobjLineItems.Count > 0 Then
IPurchaseOrder_Tax = (IPurchaseOrder_SubTotal + IPurchaseOrder_ShippingHandling) * mdblTaxRate
Else
IPurchaseOrder_Tax = 0
End If
End Property
Private Property Let IPurchaseOrder_Tax(ByVal RHS As Currency)
' Perform any data validation that does not require
' access to the data services
' Property is R/O
Err.Raise 383
End Property
Private Property Get IPurchaseOrder_TaxRate() As Double
IPurchaseOrder_TaxRate = mdblTaxRate
End Property
Private Property Let IPurchaseOrder_TaxRate(ByVal RHS As Double)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' TaxRate cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
mdblTaxRate = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_TAXRATE, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_TAXRATE, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_TAXRATE)
End If
End Property
Private Property Get IPurchaseOrder_Total() As Currency
' Don't charge for shipping unless there are
' items actually being purchased
If mobjLineItems.Count > 0 Then
IPurchaseOrder_Total = IPurchaseOrder_SubTotal + IPurchaseOrder_ShippingHandling + IPurchaseOrder_Tax
Else
IPurchaseOrder_Total = 0
End If
End Property
Private Property Let IPurchaseOrder_Total(ByVal RHS As Currency)
Dim blnInvalid As Boolean
' Perform any data validation that does not require
' access to the data services
' Total cannot have a negative value
If RHS < 0 Then
blnInvalid = True
Else
blnInvalid = False
mcurTotal = RHS
End If
' Track whether or not the property is invalid
mobjInvalidProperties.Track IDS_INVALID_PURCHASEORDER_TOTAL, blnInvalid
' Notify the client of any error
If blnInvalid Then
Err.Raise vbObjectError + IDS_INVALID_PURCHASEORDER_TOTAL, LoadResString(IDS_PROJECTNAME), LoadResString(IDS_INVALID_PURCHASEORDER_TOTAL)
End If
End Property
Public Property Get ID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
ID = IPurchaseOrder_ID
End Property
Public Property Let ID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ID = lngNewValue
End Property
Public Property Get AccountID() As Long
' Delegate the default interface implementation
' to the appropriate interface implementation
AccountID = IPurchaseOrder_AccountID
End Property
Public Property Let AccountID(ByVal lngNewValue As Long)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_AccountID = lngNewValue
End Property
Public Property Get OrderDate() As Date
' Delegate the default interface implementation
' to the appropriate interface implementation
OrderDate = IPurchaseOrder_OrderDate
End Property
Public Property Let OrderDate(ByVal datNewValue As Date)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_OrderDate = datNewValue
End Property
Public Property Get SubTotal() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
SubTotal = IPurchaseOrder_SubTotal
End Property
Public Property Let SubTotal(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_SubTotal = curNewValue
End Property
Public Property Get ShippingHandling() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
ShippingHandling = IPurchaseOrder_ShippingHandling
End Property
Public Property Let ShippingHandling(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShippingHandling = curNewValue
End Property
Public Property Get TaxRate() As Double
' Delegate the default interface implementation
' to the appropriate interface implementation
TaxRate = IPurchaseOrder_TaxRate
End Property
Public Property Let TaxRate(ByVal dblNewValue As Double)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_TaxRate = dblNewValue
End Property
Public Property Get Total() As Currency
' Delegate the default interface implementation
' to the appropriate interface implementation
Total = IPurchaseOrder_Total
End Property
Public Property Let Total(ByVal curNewValue As Currency)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_Total = curNewValue
End Property
Public Property Get ShipToFirstName() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToFirstName = IPurchaseOrder_ShipToFirstName
End Property
Public Property Let ShipToFirstName(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToFirstName = strNewValue
End Property
Public Property Get ShipToLastName() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToLastName = IPurchaseOrder_ShipToLastName
End Property
Public Property Let ShipToLastName(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToLastName = strNewValue
End Property
Public Property Get ShipToAddressLine1() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToAddressLine1 = IPurchaseOrder_ShipToAddressLine1
End Property
Public Property Let ShipToAddressLine1(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToAddressLine1 = strNewValue
End Property
Public Property Get ShipToAddressLine2() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToAddressLine2 = IPurchaseOrder_ShipToAddressLine2
End Property
Public Property Let ShipToAddressLine2(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToAddressLine2 = strNewValue
End Property
Public Property Get ShipToCity() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToCity = IPurchaseOrder_ShipToCity
End Property
Public Property Let ShipToCity(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToCity = strNewValue
End Property
Public Property Get ShipToState() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToState = IPurchaseOrder_ShipToState
End Property
Public Property Let ShipToState(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToState = strNewValue
End Property
Public Property Get ShipToZip() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToZip = IPurchaseOrder_ShipToZip
End Property
Public Property Let ShipToZip(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToZip = strNewValue
End Property
Public Property Get ShipToPhone() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToPhone = IPurchaseOrder_ShipToPhone
End Property
Public Property Let ShipToPhone(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToPhone = strNewValue
End Property
Public Property Get ShipToEmail() As String
' Delegate the default interface implementation
' to the appropriate interface implementation
ShipToEmail = IPurchaseOrder_ShipToEmail
End Property
Public Property Let ShipToEmail(ByVal strNewValue As String)
' Delegate the default interface implementation
' to the appropriate interface implementation
IPurchaseOrder_ShipToEmail = strNewValue
End Property
Public Property Get LineItems() As LineItems
Set LineItems = mobjLineItems
End Property
Private Property Get IPurchaseOrder_Valid() As Boolean
' The entire object cannot be valid unless
' all of its properties are valid
IPurchaseOrder_Valid = (mobjInvalidProperties.Count = 0)
End Property
Listing 53
' Constants
Option Explicit
Public Enum PurchaseOrderEmissaryConstants
' Project Name
IDS_PROJECTNAME = 101
' Account Emissary Errors
IDS_INVALID_ACCOUNT_FIRSTNAME
IDS_INVALID_ACCOUNT_LASTNAME
IDS_INVALID_ACCOUNT_ADDRESS
IDS_INVALID_ACCOUNT_CITY
IDS_INVALID_ACCOUNT_STATE
IDS_INVALID_ACCOUNT_ZIP
IDS_INVALID_ACCOUNT_DESTROY
IDS_INVALID_ACCOUNT_SAVE
' Inventory Emissary Errors
IDS_INVALID_INVENTORY_DESCRIPTION
IDS_INVALID_INVENTORY_PRICE
IDS_INVALID_INVENTORY_QOH
IDS_INVALID_INVENTORY_DESTROY
IDS_INVALID_INVENTORY_SAVE
' LineItem Emissary Errors
IDS_INVALID_LINEITEM_ITEM
IDS_INVALID_LINEITEM_PRICE
IDS_INVALID_LINEITEM_QUANTITY
IDS_INVALID_LINEITEM_DESTROY
IDS_INVALID_LINEITEM_SAVE
' PurchaseOrder Emissary Errors
IDS_INVALID_PURCHASEORDER_ACCOUNTID
IDS_INVALID_PURCHASEORDER_SHIPPINGHANDLING
IDS_INVALID_PURCHASEORDER_SHIPTOFIRSTNAME
IDS_INVALID_PURCHASEORDER_SHIPTOLASTNAME
IDS_INVALID_PURCHASEORDER_SHIPTOADDRESS
IDS_INVALID_PURCHASEORDER_SHIPTOCITY
IDS_INVALID_PURCHASEORDER_SHIPTOSTATE
IDS_INVALID_PURCHASEORDER_SHIPTOZIP
IDS_INVALID_PURCHASEORDER_TAXRATE
IDS_INVALID_PURCHASEORDER_TOTAL
IDS_INVALID_PURCHASEORDER_CANCEL
IDS_INVALID_PURCHASEORDER_DESTROY
IDS_INVALID_PURCHASEORDER_SAVE
End Enum
Listing 54
' Global
Option Explicit
Public Sub HighlightContents(robjTextbox As TextBox)
robjTextbox.SelStart = 0
robjTextbox.SelLength = Len(robjTextbox.Text)
End Sub
Listing 55
'frmPurchaseOrderManagement
Option Explicit
Private mobjPurchaseOrderIterator As PurchaseOrderIterator
Private Sub DisplayPurchaseOrders()
Dim objPurchaseOrder As PurchaseOrder
Dim objListViewItemAdded As ListItem
' Clear any existing contents
lvPurchaseOrders.ListItems.Clear
Set mobjPurchaseOrderIterator = New PurchaseOrderIterator
mobjPurchaseOrderIterator.Initialize
' Display the PurchaseOrders
Do While Not mobjPurchaseOrderIterator.EOF
Set objPurchaseOrder = mobjPurchaseOrderIterator.Item
Set objListViewItemAdded = lvPurchaseOrders.ListItems.Add(, "Key=" & CStr(objPurchaseOrder.ID), CStr(objPurchaseOrder.ID))
' AccountID
objListViewItemAdded.SubItems(1) = CStr(objPurchaseOrder.AccountID)
' OrderDate
objListViewItemAdded.SubItems(2) = CStr(objPurchaseOrder.OrderDate)
mobjPurchaseOrderIterator.MoveNext
Loop
' Enable the Modify, Destroy, and CancelOrder buttons if necessary
cmdModify.Enabled = Not (lvPurchaseOrders.SelectedItem Is Nothing)
cmdDestroy.Enabled = cmdModify.Enabled
cmdCancelOrder.Enabled = cmdModify.Enabled
' Clean Up
Set objListViewItemAdded = Nothing
Set objPurchaseOrder = Nothing
End Sub
Private Sub cmdCancelOrder_Click()
Dim objListViewItemSelected As ListItem
Dim objPurchaseOrder As PurchaseOrder
' Get the selected item
Set objListViewItemSelected = lvPurchaseOrders.SelectedItem
mobjPurchaseOrderIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objPurchaseOrder = mobjPurchaseOrderIterator.Item
If vbYes = MsgBox("Are you sure you want to cancel PurchaseOrder # " & objPurchaseOrder.ID & " ?", vbYesNo) Then
On Error GoTo ErrorHandler
If objPurchaseOrder.Cancel() Then DisplayPurchaseOrders
End If
CleanUp:
Set objPurchaseOrder = Nothing
Set objListViewItemSelected = Nothing
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
GoTo CleanUp
End Sub
Private Sub cmdCreate_Click()
If frmPurchaseOrderDetailed.CreatePurchaseOrder() Then DisplayPurchaseOrders
End Sub
Private Sub cmdDestroy_Click()
Dim objListViewItemSelected As ListItem
Dim objPurchaseOrder As PurchaseOrder
' Get the selected item
Set objListViewItemSelected = lvPurchaseOrders.SelectedItem
mobjPurchaseOrderIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objPurchaseOrder = mobjPurchaseOrderIterator.Item
If vbYes = MsgBox("Are you sure you want to delete PurchaseOrder # " & objPurchaseOrder.ID & " ?", vbYesNo) Then
On Error GoTo ErrorHandler
If objPurchaseOrder.Destroy() Then DisplayPurchaseOrders
End If
CleanUp:
Set objPurchaseOrder = Nothing
Set objListViewItemSelected = Nothing
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
GoTo CleanUp
End Sub
Private Sub cmdModify_Click()
Dim objListViewItemSelected As ListItem
Dim objPurchaseOrder As PurchaseOrder
' Get the selected item
Set objListViewItemSelected = lvPurchaseOrders.SelectedItem
mobjPurchaseOrderIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objPurchaseOrder = mobjPurchaseOrderIterator.Item
If frmPurchaseOrderDetailed.ModifyPurchaseOrder(objPurchaseOrder) Then DisplayPurchaseOrders
Set objPurchaseOrder = Nothing
Set objListViewItemSelected = Nothing
End Sub
Private Sub Form_Load()
mnuViewRefresh_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjPurchaseOrderIterator = Nothing
Set frmPurchaseOrderManagement = Nothing
End Sub
Private Sub lvPurchaseOrders_DblClick()
If cmdModify.Enabled Then cmdModify_Click
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuManageAccounts_Click()
Load frmAccountManagement
frmAccountManagement.Show 1
Unload frmAccountManagement
End Sub
Private Sub mnuManageInventory_Click()
Load frmInventoryManagement
frmInventoryManagement.Show 1
Unload frmInventoryManagement
End Sub
Private Sub mnuViewRefresh_Click()
DisplayPurchaseOrders
End Sub
Listing 56
' frmPurchaseOrderDetailed
Option Explicit
Private mobjPurchaseOrder As PurchaseOrder
Private mblnCanceled As Boolean
Private mblnUpdatingUI As Boolean
Public Function CreatePurchaseOrder() As Boolean
' Create a new blank 'current' PurchaseOrder
Set mobjPurchaseOrder = New PurchaseOrder
Load Me
Label1.Caption = "Create a New Purchase Order"
DisplayCurrentPurchaseOrder
' Enable the Remove button if necessary
cmdRemove.Enabled = Not (lvLineItems.SelectedItem Is Nothing)
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
CreatePurchaseOrder = Not mblnCanceled
Unload Me
End Function
Private Sub DisplayCurrentPurchaseOrder()
' Signal that we are updating the UI
mblnUpdatingUI = True
' Display the PurchaseOrder information
DisplayLineItems
' Display the Shipping information
txtFirstName.Text = mobjPurchaseOrder.ShipToFirstName
txtLastName.Text = mobjPurchaseOrder.ShipToLastName
txtAddressLine1.Text = mobjPurchaseOrder.ShipToAddressLine1
txtAddressLine2.Text = mobjPurchaseOrder.ShipToAddressLine2
txtCity.Text = mobjPurchaseOrder.ShipToCity
txtState.Text = mobjPurchaseOrder.ShipToState
txtZip.Text = mobjPurchaseOrder.ShipToZip
txtPhone.Text = mobjPurchaseOrder.ShipToPhone
txtEmail.Text = mobjPurchaseOrder.ShipToEmail
' Done updating the UI
mblnUpdatingUI = False
End Sub
Private Sub DisplayLineItems()
Dim lngItem As Long
Dim objLineItem As LineItem
Dim objListViewItemAdded As ListItem
' Clear any existing contents
lvLineItems.ListItems.Clear
' Iterate and display each line item
For lngItem = 1 To mobjPurchaseOrder.LineItems.Count
Set objLineItem = mobjPurchaseOrder.LineItems.Item(lngItem)
If Not objLineItem Is Nothing Then
' Quantity
Set objListViewItemAdded = lvLineItems.ListItems.Add(, "Key=" & CStr(lngItem), CStr(objLineItem.Quantity))
' Title
objListViewItemAdded.SubItems(1) = objLineItem.Item.Description
' Price
objListViewItemAdded.SubItems(2) = Format$(objLineItem.Price, "Currency")
End If
Next lngItem
' Display the Payment information
txtAccountID.Text = CStr(mobjPurchaseOrder.AccountID)
lblSubTotal.Caption = Format$(mobjPurchaseOrder.SubTotal, "Currency")
lblShipping.Caption = Format$(mobjPurchaseOrder.ShippingHandling, "Currency")
lblTaxRate.Caption = Format$(mobjPurchaseOrder.TaxRate, "Tax #0.000%")
lblTax.Caption = Format$(mobjPurchaseOrder.Tax, "Currency")
lblTotal.Caption = Format$(mobjPurchaseOrder.Total, "Currency")
Set objLineItem = Nothing
Set objListViewItemAdded = Nothing
End Sub
Public Function ModifyPurchaseOrder(robjPurchaseOrder As PurchaseOrder) As Boolean
' Make the incoming PurchaseOrder the 'current' PurchaseOrder
Set mobjPurchaseOrder = robjPurchaseOrder
Load Me
Label1.Caption = "Purchase Order - " & CStr(mobjPurchaseOrder.ID)
DisplayCurrentPurchaseOrder
' Enable the Remove button if necessary
cmdRemove.Enabled = Not (lvLineItems.SelectedItem Is Nothing)
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
ModifyPurchaseOrder = Not mblnCanceled
Unload Me
End Function
Private Sub EnableDoneButton()
' Only enable the Done button if the
' entire object is valid
cmdDone.Enabled = mobjPurchaseOrder.Valid
End Sub
Private Sub cmdAdd_Click()
Dim objInventory As Inventory
Dim objLineItem As New LineItem
Set objInventory = frmInventorySelection.SelectItem()
If Not objInventory Is Nothing Then
' Add the item to the PO
objLineItem.PurchaseOrderID = mobjPurchaseOrder.ID
Set objLineItem.Item = objInventory
objLineItem.Price = objInventory.Price
objLineItem.Quantity = 1
mobjPurchaseOrder.LineItems.Add objLineItem
' Update the display
DisplayLineItems
' Enable the Remove button if necessary
cmdRemove.Enabled = Not (lvLineItems.SelectedItem Is Nothing)
' Enable the Done button if necessary
EnableDoneButton
End If
Set objLineItem = Nothing
Set objInventory = Nothing
End Sub
Private Sub cmdCancel_Click()
Me.Hide
End Sub
Private Sub cmdDone_Click()
On Error GoTo ErrorHandler
If mobjPurchaseOrder.Save() Then
mblnCanceled = False
Me.Hide
End If
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
End Sub
Private Sub cmdRemove_Click()
' Remove the currently selected
' line item from the PO
mobjPurchaseOrder.LineItems.Remove lvLineItems.SelectedItem.Index
' Update the display
DisplayLineItems
' Enable the Remove button if necessary
cmdRemove.Enabled = Not (lvLineItems.SelectedItem Is Nothing)
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub Form_Load()
mblnCanceled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjPurchaseOrder = Nothing
Set frmPurchaseOrderDetailed = Nothing
End Sub
Private Sub lvLineItems_AfterLabelEdit(Cancel As Integer, NewString As String)
Dim objLineItem As LineItem
Dim objListViewItemSelected As ListItem
' Update the Quantity to purchase
Set objListViewItemSelected = lvLineItems.SelectedItem
If Not objListViewItemSelected Is Nothing Then
Set objLineItem = mobjPurchaseOrder.LineItems.Item(objListViewItemSelected.Index)
If Not objLineItem Is Nothing Then
objLineItem.Quantity = CLng(NewString)
' Update the display
DisplayLineItems
End If
End If
Set objListViewItemSelected = Nothing
Set objLineItem = Nothing
End Sub
Private Sub txtAccountID_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
If Trim$(txtAccountID.Text) = "" Then
mobjPurchaseOrder.AccountID = 0
Else
mobjPurchaseOrder.AccountID = CLng(txtAccountID.Text)
End If
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtAccountID_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.AccountID = CLng(txtAccountID.Text)
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtAccountID
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtAddressLine1_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToAddressLine1 = txtAddressLine1.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtAddressLine1_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToAddressLine1 = txtAddressLine1.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtAddressLine1
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtAddressLine2_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToAddressLine2 = txtAddressLine2.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtAddressLine2_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToAddressLine2 = txtAddressLine2.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtAddressLine2
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtCity_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToCity = txtCity.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtCity_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToCity = txtCity.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtCity
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtEmail_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToEmail = txtEmail.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtEmail_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToEmail = txtEmail.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtEmail
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtFirstName_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToFirstName = txtFirstName.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtFirstName_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToFirstName = txtFirstName.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtFirstName
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtLastName_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToLastName = txtLastName.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtLastName_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToLastName = txtLastName.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtLastName
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtPhone_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToPhone = txtPhone.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtPhone_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToPhone = txtPhone.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtPhone
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtState_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToState = txtState.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtState_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToState = txtState.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtState
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtZip_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjPurchaseOrder.ShipToZip = txtZip.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtZip_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjPurchaseOrder.ShipToZip = txtZip.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtZip
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Listing 57
' frmInventorySelection
Option Explicit
Private mobjInventoryIterator As InventoryIterator
Private mblnCanceled As Boolean
Private Sub DisplayInventory()
Dim objInventory As Inventory
Dim objListViewItemAdded As ListItem
' Clear any existing contents
lvInventory.ListItems.Clear
Set mobjInventoryIterator = New InventoryIterator
mobjInventoryIterator.Initialize
' Sort the items
mobjInventoryIterator.Sort = "Description ASC"
' Display the Inventory Items
Do While Not mobjInventoryIterator.EOF
Set objInventory = mobjInventoryIterator.Item
Set objListViewItemAdded = lvInventory.ListItems.Add(, "Key=" & CStr(objInventory.ID), CStr(objInventory.ID))
' Description
objListViewItemAdded.SubItems(1) = objInventory.Description
' Price
objListViewItemAdded.SubItems(2) = Format$(objInventory.Price, "Currency")
' Quantity On Hand
objListViewItemAdded.SubItems(3) = CStr(objInventory.QOH)
mobjInventoryIterator.MoveNext
Loop
' Enable the Done button if necessary
cmdDone.Enabled = Not (lvInventory.SelectedItem Is Nothing)
' Clean Up
Set objListViewItemAdded = Nothing
Set objInventory = Nothing
End Sub
Public Function SelectItem() As Inventory
Dim objListViewItemSelected As ListItem
Load Me
' Display the Inventory information
DisplayInventory
' Enable the Done button if necessary
cmdDone.Enabled = (lvInventory.ListItems.Count > 0)
Me.Show 1
If Not mblnCanceled Then
' Get the selected item
Set objListViewItemSelected = lvInventory.SelectedItem
mobjInventoryIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set SelectItem = mobjInventoryIterator.Item
End If
Unload Me
Set objListViewItemSelected = Nothing
End Function
Private Sub cmdCancel_Click()
Me.Hide
End Sub
Private Sub cmdDone_Click()
mblnCanceled = False
Me.Hide
End Sub
Private Sub Form_Load()
mblnCanceled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set frmInventorySelection = Nothing
End Sub
Private Sub lvInventory_DblClick()
If cmdDone.Enabled Then cmdDone_Click
End Sub
Listing 58
' frmInventoryManagement
Option Explicit
Private mobjInventoryIterator As InventoryIterator
Private Sub DisplayInventory()
Dim objInventory As Inventory
Dim objListViewItemAdded As ListItem
' Clear any existing contents
lvInventory.ListItems.Clear
Set mobjInventoryIterator = New InventoryIterator
mobjInventoryIterator.Initialize
' Sort the items
mobjInventoryIterator.Sort = "Description ASC"
' Display the Inventory Items
Do While Not mobjInventoryIterator.EOF
Set objInventory = mobjInventoryIterator.Item
Set objListViewItemAdded = lvInventory.ListItems.Add(, "Key=" & CStr(objInventory.ID), CStr(objInventory.ID))
' Description
objListViewItemAdded.SubItems(1) = objInventory.Description
' Price
objListViewItemAdded.SubItems(2) = Format$(objInventory.Price, "Currency")
' Quantity On Hand
objListViewItemAdded.SubItems(3) = CStr(objInventory.QOH)
mobjInventoryIterator.MoveNext
Loop
' Enable the Modify and Destroy buttons if necessary
cmdModify.Enabled = Not (lvInventory.SelectedItem Is Nothing)
cmdDestroy.Enabled = cmdModify.Enabled
' Clean Up
Set objListViewItemAdded = Nothing
Set objInventory = Nothing
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdCreate_Click()
If frmInventoryDetailed.CreateInventory() Then DisplayInventory
End Sub
Private Sub cmdDestroy_Click()
Dim objListViewItemSelected As ListItem
Dim objInventory As Inventory
' Get the selected item
Set objListViewItemSelected = lvInventory.SelectedItem
mobjInventoryIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objInventory = mobjInventoryIterator.Item
If vbYes = MsgBox("Are you sure you want to delete Inventory item # " & objInventory.ID & " ?", vbYesNo) Then
On Error GoTo ErrorHandler
If objInventory.Destroy() Then DisplayInventory
End If
CleanUp:
Set objInventory = Nothing
Set objListViewItemSelected = Nothing
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
GoTo CleanUp
End Sub
Private Sub cmdModify_Click()
Dim objListViewItemSelected As ListItem
Dim objInventory As Inventory
' Get the selected item
Set objListViewItemSelected = lvInventory.SelectedItem
mobjInventoryIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objInventory = mobjInventoryIterator.Item
If frmInventoryDetailed.ModifyInventory(objInventory) Then DisplayInventory
Set objInventory = Nothing
Set objListViewItemSelected = Nothing
End Sub
Private Sub Form_Load()
DisplayInventory
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjInventoryIterator = Nothing
Set frmInventoryManagement = Nothing
End Sub
Private Sub lvInventory_DblClick()
If cmdModify.Enabled Then cmdModify_Click
End Sub
Listing 59
' frmInventoryDetailed
Option Explicit
Private mobjInventory As Inventory
Private mblnCanceled As Boolean
Private mblnUpdatingUI As Boolean
Public Function CreateInventory() As Boolean
' Create a new blank 'current' Inventory item
Set mobjInventory = New Inventory
Load Me
Label1.Caption = "Create a New Inventory Item"
DisplayCurrentInventory
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
CreateInventory = Not mblnCanceled
Unload Me
End Function
Private Sub DisplayCurrentInventory()
' Signal that we are updating the UI
mblnUpdatingUI = True
' Display the Inventory information
txtDescription.Text = mobjInventory.Description
txtPrice.Text = Format$(mobjInventory.Price, "Currency")
txtQOH.Text = CStr(mobjInventory.QOH)
' Done updating the UI
mblnUpdatingUI = False
End Sub
Public Function ModifyInventory(robjInventory As Inventory) As Boolean
' Make the incoming Inventory item the 'current' Inventory item
Set mobjInventory = robjInventory
Load Me
Label1.Caption = "Inventory Item - " & CStr(mobjInventory.ID)
DisplayCurrentInventory
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
ModifyInventory = Not mblnCanceled
Unload Me
End Function
Private Sub EnableDoneButton()
' Only enable the Done button if the
' entire object is valid
cmdDone.Enabled = mobjInventory.Valid
End Sub
Private Sub cmdCancel_Click()
Me.Hide
End Sub
Private Sub cmdDone_Click()
On Error GoTo ErrorHandler
If mobjInventory.Save() Then
mblnCanceled = False
Me.Hide
End If
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
End Sub
Private Sub Form_Load()
mblnCanceled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjInventory = Nothing
Set frmInventoryDetailed = Nothing
End Sub
Private Sub txtDescription_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjInventory.Description = txtDescription.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtDescription_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjInventory.Description = txtDescription.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtDescription
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtPrice_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjInventory.Price = CCur(txtPrice.Text)
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtPrice_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjInventory.Price = CCur(txtPrice.Text)
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtPrice
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtQOH_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjInventory.QOH = CLng(txtQOH.Text)
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtQOH_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjInventory.QOH = CLng(txtQOH.Text)
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtQOH
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Listing 60
' frmAccountManagement
Option Explicit
Private mobjAccountIterator As AccountIterator
Private Sub DisplayAccounts()
Dim objAccount As Account
Dim objListViewItemAdded As ListItem
' Clear any existing contents
lvAccounts.ListItems.Clear
Set mobjAccountIterator = New AccountIterator
mobjAccountIterator.Initialize
' Sort the items
mobjAccountIterator.Sort = "LastName ASC, FirstName ASC"
' Display the Accounts
Do While Not mobjAccountIterator.EOF
Set objAccount = mobjAccountIterator.Item
Set objListViewItemAdded = lvAccounts.ListItems.Add(, "Key=" & CStr(objAccount.ID), CStr(objAccount.ID))
' Owner
objListViewItemAdded.SubItems(1) = objAccount.LastName & ", " & objAccount.FirstName
' Current Balance
objListViewItemAdded.SubItems(2) = Format$(objAccount.Balance, "Currency")
' Available Credit
objListViewItemAdded.SubItems(3) = Format$(objAccount.Limit - objAccount.Balance, "Currency")
' Credit Limit
objListViewItemAdded.SubItems(4) = Format$(objAccount.Limit, "Currency")
mobjAccountIterator.MoveNext
Loop
' Enable the Modify and Destroy buttons if necessary
cmdModify.Enabled = Not (lvAccounts.SelectedItem Is Nothing)
cmdDestroy.Enabled = cmdModify.Enabled
' Clean Up
Set objListViewItemAdded = Nothing
Set objAccount = Nothing
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdCreate_Click()
If frmAccountDetailed.CreateAccount() Then DisplayAccounts
End Sub
Private Sub cmdDestroy_Click()
Dim objListViewItemSelected As ListItem
Dim objAccount As Account
' Get the selected item
Set objListViewItemSelected = lvAccounts.SelectedItem
mobjAccountIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objAccount = mobjAccountIterator.Item
If vbYes = MsgBox("Are you sure you want to delete Account # " & objAccount.ID & " ?", vbYesNo) Then
On Error GoTo ErrorHandler
If objAccount.Destroy() Then DisplayAccounts
End If
CleanUp:
Set objAccount = Nothing
Set objListViewItemSelected = Nothing
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
GoTo CleanUp
End Sub
Private Sub cmdModify_Click()
Dim objListViewItemSelected As ListItem
Dim objAccount As Account
' Get the selected item
Set objListViewItemSelected = lvAccounts.SelectedItem
mobjAccountIterator.Filter = "ID = " & Mid$(objListViewItemSelected.Key, 5)
Set objAccount = mobjAccountIterator.Item
If frmAccountDetailed.ModifyAccount(objAccount) Then DisplayAccounts
Set objAccount = Nothing
Set objListViewItemSelected = Nothing
End Sub
Private Sub Form_Load()
DisplayAccounts
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjAccountIterator = Nothing
Set frmAccountManagement = Nothing
End Sub
Private Sub lvAccounts_DblClick()
If cmdModify.Enabled Then cmdModify_Click
End Sub
Listing 61
' frmAccountDetailed
Option Explicit
Private mobjAccount As Account
Private mblnCanceled As Boolean
Private mblnUpdatingUI As Boolean
Private Sub DisplayCurrentAccount()
' Signal that we are updating the UI
mblnUpdatingUI = True
' Display the Account information
txtFirstName.Text = mobjAccount.FirstName
txtLastName.Text = mobjAccount.LastName
txtAddressLine1.Text = mobjAccount.AddressLine1
txtAddressLine2.Text = mobjAccount.AddressLine2
txtCity.Text = mobjAccount.City
txtState.Text = mobjAccount.State
txtZip.Text = mobjAccount.Zip
txtPhone.Text = mobjAccount.Phone
txtEmail.Text = mobjAccount.Email
txtBalance.Text = Format$(mobjAccount.Balance, "Currency")
txtLimit.Text = Format$(mobjAccount.Limit, "Currency")
' Done updating the UI
mblnUpdatingUI = False
End Sub
Public Function ModifyAccount(robjAccount As Account) As Boolean
' Make the incoming Account the 'current' Account
Set mobjAccount = robjAccount
Load Me
Label1.Caption = "Account - " & CStr(mobjAccount.ID)
DisplayCurrentAccount
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
ModifyAccount = Not mblnCanceled
Unload Me
End Function
Public Function CreateAccount() As Boolean
' Create a new blank 'current' Account
Set mobjAccount = New Account
Load Me
Label1.Caption = "Create a New Account"
DisplayCurrentAccount
' Enable the Done button if necessary
EnableDoneButton
Me.Show 1
CreateAccount = Not mblnCanceled
Unload Me
End Function
Private Sub cmdCancel_Click()
Me.Hide
End Sub
Private Sub cmdDone_Click()
On Error GoTo ErrorHandler
If mobjAccount.Save() Then
mblnCanceled = False
Me.Hide
End If
Exit Sub
ErrorHandler:
' Inform the user of the invalid operation
MsgBox Err.Description, vbExclamation
End Sub
Private Sub Form_Load()
mblnCanceled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mobjAccount = Nothing
Set frmAccountDetailed = Nothing
End Sub
Private Sub txtAddressLine1_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.AddressLine1 = txtAddressLine1.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub EnableDoneButton()
' Only enable the Done button if the
' entire object is valid
cmdDone.Enabled = mobjAccount.Valid
End Sub
Private Sub txtAddressLine1_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.AddressLine1 = txtAddressLine1.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtAddressLine1
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtAddressLine2_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.AddressLine2 = txtAddressLine2.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtAddressLine2_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.AddressLine2 = txtAddressLine2.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtAddressLine2
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtBalance_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.Balance = CCur(txtBalance.Text)
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtBalance_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.Balance = txtBalance.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtBalance
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtCity_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.City = txtCity.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtCity_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.City = txtCity.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtCity
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtEmail_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.Email = txtEmail.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtEmail_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.Email = txtEmail.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtEmail
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtFirstName_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.FirstName = txtFirstName.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtFirstName_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.FirstName = txtFirstName.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtFirstName
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtLastName_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.LastName = txtLastName.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtLastName_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.LastName = txtLastName.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtLastName
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtLimit_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.Limit = CCur(txtLimit.Text)
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtLimit_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.Limit = txtLimit.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtLimit
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtPhone_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.Phone = txtPhone.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtPhone_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.Phone = txtPhone.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtPhone
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtState_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.State = txtState.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtState_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.State = txtState.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtState
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub
Private Sub txtZip_Change()
If mblnUpdatingUI Then Exit Sub
' It's best to trap errors in the
' Validate or LostFocus event so as not to disturb
' the user while they are entering data
On Error Resume Next
mobjAccount.Zip = txtZip.Text
' Enable the Done button if necessary
EnableDoneButton
End Sub
Private Sub txtZip_Validate(Cancel As Boolean)
On Error GoTo ErrorHandler
' Reassign the property value to check for
' invalid data
mobjAccount.Zip = txtZip.Text
Exit Sub
ErrorHandler:
' Inform the user of the invalid entry
MsgBox Err.Description, vbExclamation
HighlightContents txtZip
' Keep the focus and allow the user to
' enter valid data
Cancel = True
End Sub