List 6-154　Business.SlipコンポーネントのGetReadyDate_Slipメソッド

  1： Public Function GetReadyDate_Slip(ByVal SlipID As Long) As Variant
  2：     ' 指定された伝票を受け付けることができる最も近い納期を返す
  3：     ' 【引数】
  4：     '   SlipID = 調査したい伝票の伝票番号
  5：     ' 【戻り値】
  6：     '   その伝票の納期として受け付けることができる日付
  7：     '   入庫の予定がなく納期が不明のときにはNullを返す
  8：     Dim objContext As ObjectContext
  9：     Dim objDataStock As DataObj.STOCK
 10：     Dim objDataProduct As DataObj.Product
 11：     Dim objDataSlipDetail As DataObj.SlipDetail
 12：     Dim objDataSlip As DataObj.Slip
 13：     Dim objRec As ADODB.Recordset
 14：     Dim ReadyDate As Variant, tmpDate As Variant
 15：     Dim ProductID As Long, Number As Long
 16：     Dim NowStock As Long
 17：     Dim SlipStatus As SlipStatus
 18：     
 19：     ' オブジェクトコンテキストの取得
 20：     Set objContext = GetObjectContext()
 21：     
 22：     ' エラーハンドラの設定
 23：     On Error GoTo ErrHandle
 24：     
 25：     ' DataObj.Slipコンポーネントを実体化
 26：     Set objDataSlip = CreateObject("DataObj.Slip")
 27：     
 28：     ' 伝票が存在することを確認
 29：     If objDataSlip.IsDeleted(SlipID) <> ID_Exists Then
 30：         ' 伝票が存在しない
 31：         Err.Raise Errorcode.Err_NOTFOUND, App.Title, _
   　                   "指定された伝票は存在しません"
 32：     End If
 33：     
 34：     ' 伝票の状態を取得
 35：     SlipStatus = objDataSlip.Get_SlipStatus(SlipID)
 36：     If (SlipStatus <> Creating) And (SlipStatus <> Rejected) Then
 37：         ' 伝票が作成中または却下されたという状況ではない
 38：         Err.Raise BusinessError.ERR_CANTACCESS, App.Title, _
   　                   "その伝票はすでに承認依頼されています"
 39：     End If
 40：     
 41：     Set objDataStock = CreateObject("DataObj.Stock")
 42：     Set objDataProduct = CreateObject("DataObj.Product")
 43：     Set objDataSlipDetail = CreateObject("DataObj.SlipDetail")
 44：     
 45：     ' 指定した伝票に付随する明細を製品でグループ化したものを取得
 46：     Set objRec = objDataSlipDetail.GetRecords_GroupProduct(SlipID)
 47：     
 48：     ReadyDate = Date
 49：     Do While Not objRec.EOF
 50：         ProductID = objRec.Fields("PRODUCTID").Value
 51：         Number = objRec.Fields("NUMBER").Value
 52：         NowStock = objDataProduct.GetNowStock(ProductID)
 53：         If NowStock < Number Then
 54：             ' その時点の在庫では足りない
 55：             ' いつになれば揃うのかを求める
 56：             tmpDate = objDataStock.GetReadyDate(ProductID,Number - NowStock)
 57：             If IsNull(tmpDate) Then
 58：                 ' 永遠に揃うことはない
 59：                 ReadyDate = Null
 60：                 Exit Do
 61：             End If
 62：             If ReadyDate < tmpDate Then
 63：                 ReadyDate = tmpDate
 64：             End If
 65：         End If
 66：         objRec.MoveNext
 67：     Loop
 68：     
 69：     ' 戻り値を設定
 70：     GetReadyDate_Slip = ReadyDate
 71：     
 72：     objRec.Close
 73：     Set objRec = Nothing
 74：     
 75：     ' 各種コンポーネントの解放
 76：     Set objDataSlipDetail = Nothing
 77：     Set objDataProduct = Nothing
 78：     Set objDataStock = Nothing
 79：     Set objDataSlip = Nothing
 80：     
 81：     ' トランザクションのコミット
 82：     objContext.SetComplete
 83：     
 84：     ' オブジェクトコンテキストの解放
 85：     Set objContext = Nothing
 86：     
 87：     Exit Function
 88：     
 89： ErrHandle:
 90：     ' エラーハンドラ
 91：     objContext.SetAbort
 92：     Set objDataSlip = Nothing
 93：     Set objDataStock = Nothing
 94：     Set objDataProduct = Nothing
 95：     Set objDataSlipDetail = Nothing
 96：     Set objRec = Nothing
 97：     
 98：     ' エラーの再発行
 99：     Err.Raise Err.Number, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
100： End Function