List 6-78　Business.ProductコンポーネントのCancelDueメソッド

  1： Public Sub CancelDue(ByVal StockID As Long)
  2：     ' 指定された入庫予定を施行まえの状態に戻す
  3：     ' 【引数】
  4：     '   StockID = 在庫情報テーブル中の入庫予定を
  5：     '             特定するレコードID（IDフィールドの値）
  6：     ' 【戻り値】
  7：     '   なし
  8：     Dim objContext As ObjectContext
  9：     Dim objDataProduct As DataObj.Product
 10：     Dim objDataStock As DataObj.STOCK
 11：     Dim WillDate As Variant, DUEDATE As Variant, CONFIRMEDFLAG As Variant
 12：     Dim PRODUCTID As Variant, NUMBER As Variant, MEMO As Variant
 13：     Dim SLIPID As Variant, MADEUSER As Variant, MADEDATE As Variant
 14：     Dim LASTUSER As Variant, LASTDATE As Variant
 15：     
 16：     ' オブジェクトコンテキストの取得
 17：     Set objContext = GetObjectContext()
 18：     
 19：     ' エラーハンドラの設定
 20：     On Error GoTo ErrHandle
 21：     
 22：     ' DataObj.Productコンポーネントの実体化
 23：     Set objDataProduct = CreateObject("DataObj.Product")
 24：     ' DataObj.Stockコンポーネントの実体化
 25：     Set objDataStock = CreateObject("DataObj.Stock")
 26：     
 27：     ' 施行ずみであることを確認
 28：     If objDataStock.IsDue(StockID) <> STOCK_DUE Then
 29：         Err.Raise Errorcode.Err_NotFound, App.Title, _
   　                   "指定された入庫予定が見つからないか未施行のデータです"
 30：     End If
 31： 
 32：     ' 施行まえに戻す
 33：     objDataStock.SetConfirmedFlag StockID, False
 34：     
 35：     ' 現在のレコードの値を取得
 36：     objDataStock.GetRecord StockID, WillDate, DUEDATE, _
   　                            CONFIRMEDFLAG, PRODUCTID, NUMBER, _
   　                            MEMO, SLIPID, _
   　                            MADEUSER, MADEDATE, LASTUSER, LASTDATE
 37：     
 38：     ' 出庫予定ではないことを確認
 39：     If Not IsNull(SLIPID) Then
 40：         ' これは出庫用のレコード
 41：         Err.Raise BusinessError.ERR_CANTACCESS, App.Title, _
   　                   "出庫予定を操作することはできません"
 42：     End If
 43：     
 44：     ' 在庫から入庫数を減らす
 45：     objDataProduct.AddStock PRODUCTID, -NUMBER
 46：     
 47：     ' DataObj.Stockの解放
 48：     Set objDataStock = Nothing
 49：     ' DataObj.Productの解放
 50：     Set objDataProduct = Nothing
 51：     
 52：     Exit Sub
 53：     
 54： ErrHandle:
 55：     ' エラーハンドラ
 56：     objContext.SetAbort
 57：     Set objContext = Nothing
 58：     Set objDataProduct = Nothing
 59：     Set objDataStock = Nothing
 60：     
 61：     ' エラーの再発行
 62：     Err.Raise Err.NUMBER, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
 63： End Sub