List 6-152　DataObj.StockコンポーネントのGetReadyDateメソッド

  1： Public Function GetReadyDate(ByVal ProductID As Long, _
   　                              ByVal Number As Long) As Variant
  2：     ' 指定された製品が指定された数量だけ今後入庫する最短の日付を返す
  3：     ' もし，将来的にその数量だけ入庫する予定がなければNullを返す
  4：     ' 【引数】
  5：     '   ProductID = 調査する製品の製品番号
  6：     '   Number = 数量
  7：     ' 【戻り値】
  8：     ' 指定された数量が入庫する日付。
  9：     ' 永遠にその数量だけ入庫する予定がなければNull
 10：     Dim objContext As ObjectContext
 11：     Dim objConn As ADODB.Connection
 12：     Dim objRec As ADODB.Recordset
 13：     Dim NumberTotal As Long
 14：     Dim ReadyDate As Variant
 15：     
 16：     ' オブジェクトコンテキストの取得
 17：     Set objContext = GetObjectContext()
 18：     
 19：     ' エラーハンドラの設定
 20：     On Error GoTo ErrHandle
 21：     
 22：     ' データベースに接続し，SQL文を実行する
 23：     Set objConn = CreateObject("ADODB.Connection")
 24：     objConn.Open g_DBConnection
 25：     Set objRec = objConn.Execute( _
   　                      "SELECT * FROM 在庫情報" & _
   　                      " WHERE NUMBER > 0 AND CONFIRMEDFLAG = 0" & _
   　                      " AND DELETEDFLAG = 0" & _
   　                      " AND PRODUCTID=" & ProductID & _
   　                      " ORDER BY DATE")
 26：                      
 27：     ' 指定された数量が揃うまでの日付を求める
 28：     NumberTotal = 0
 29：     ReadyDate = Null
 30：     
 31：     Do While Not objRec.EOF
 32：         NumberTotal = NumberTotal + objRec.Fields("NUMBER").Value
 33：         If NumberTotal >= Number Then
 34：             ' 指定された数量が揃った
 35：             ' このときの日付が指定された数量が揃う日付となる
 36：             ReadyDate = objRec.Fields("DATE").Value
 37：             Exit Do
 38：         End If
 39：         objRec.MoveNext
 40：     Loop
 41：     
 42：     ' 戻り値を設定
 43：     GetReadyDate = ReadyDate
 44：     
 45：     ' データベースとの接続を閉じてレコードセットを解放
 46：     Set objRec = Nothing
 47：     objConn.Close
 48：     Set objConn = Nothing
 49：     
 50：     ' トランザクションのコミット
 51：     objContext.SetComplete
 52：     
 53：     ' オブジェクトコンテキストの解放
 54：     Set objContext = Nothing
 55：     
 56：     Exit Function
 57： 
 58： ErrHandle:
 59：     ' エラーハンドラ
 60：     objContext.SetAbort
 61：     Set objContext = Nothing
 62：     Set objConn = Nothing
 63：     Set objRec = Nothing
 64：     
 65：     ' エラーの再発行
 66：     Err.Raise Err.Number, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
 67： End Function