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

  1： Public Function GetWillStock(ByVal ProductID As Long, _
   　                              ByVal willDate As Variant) As Long
  2：     ' 指定された日付までに指定された製品がいくつ入庫するのかを返す
  3：     ' 【引数】
  4：     '   ProductID = 調査したい製品の製品番号
  5：     '   willDate = 調査したい日付（この日を含む）
  6：     ' 【戻り値】
  7：     '   指定された日付までに入庫する数量
  8：     Dim objContext As ObjectContext
  9：     Dim objConn As ADODB.Connection
 10：     Dim objRec As ADODB.Recordset
 11：     
 12：     ' オブジェクトコンテキストの取得
 13：     Set objContext = GetObjectContext()
 14：     
 15：     ' エラーハンドラの設定
 16：     On Error GoTo ErrHandle
 17：     
 18：     ' 日付が正しいかどうか
 19：     If IsNull(willDate) Or (Not IsDate(willDate)) Then
 20：         Err.Raise Errorcode.Err_WILLDAY, App.Title, _
   　                   "日付が不正です"
 21：     End If
 22：     
 23：     ' データベースに接続し，SQL文を実行する
 24：     Set objConn = CreateObject("ADODB.Connection")
 25：     objConn.Open g_DBConnection
 26：     Set objRec = objConn.Execute( _
   　                      "SELECT SUM(NUMBER) As SUMNUMBER FROM 在庫情報 " & _
   　                      " WHERE CONFIRMEDFLAG = 0 AND NUMBER > 0" & _
   　                      " AND DATE <= '" & FormatDateTime(willDate) & "'" & _
   　                      " AND PRODUCTID=" & ProductID & _
   　                      " AND DELETEDFLAG = 0")
 27：         
 28：     If objRec.EOF Then
 29：         ' 見つからない場合には0を返す
 30：         GetWillStock = 0
 31：     Else
 32：         If Not IsNull(objRec.Fields("SUMNUMBER").Value) Then
 33：             GetWillStock = objRec.Fields("SUMNUMBER").Value
 34：         Else
 35：             GetWillStock = 0
 36：         End If
 37：     End If
 38： 
 39：     ' データベースとの接続を閉じてレコードセットを解放
 40：     Set objRec = Nothing
 41：     objConn.Close
 42：     Set objConn = Nothing
 43：     
 44：     ' トランザクションのコミット
 45：     objContext.SetComplete
 46：     
 47：     ' オブジェクトコンテキストの解放
 48：     Set objContext = Nothing
 49：     
 50：     Exit Function
 51： 
 52： ErrHandle:
 53：     ' エラーハンドラ
 54：     objContext.SetAbort
 55：     Set objContext = Nothing
 56：     Set objConn = Nothing
 57：     Set objRec = Nothing
 58：     
 59：     ' エラーの再発行
 60：     Err.Raise Err.NUMBER, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
 61： End Function