List 6-33　Business.CustomerコンポーネントのDeleteCustomerメソッド

  1： Public Sub DeleteCustomer(ByVal ID As Long)
  2：     ' 指定された顧客番号をもつ顧客を削除する
  3：     ' DELETEDFLAGフィールドがFalseであればそれをTrueに
  4：     ' DELETEDFLAGフィールドがTrueでありかつSalesAdminロール
  5：     ' またはAllAdminロールに属するユーザーから呼び出されたならば
  6：     ' レコードそのものを削除する
  7：     ' 【引数】
  8：     '   ID = 削除したい顧客を特定する顧客番号を指定する
  9：     ' 【戻り値】
 10：     '   なし
 11：     Dim objContext As ObjectContext
 12：     Dim objDataCustomer As DataObj.Customer
 13：     Dim objDataBill As DataObj.Bill
 14：     Dim objDataSlip As DataObj.Slip
 15：     
 16：     ' オブジェクトコンテキストの取得
 17：     Set objContext = GetObjectContext()
 18：     
 19：     ' エラーハンドラの設定
 20：     On Error GoTo ErrHandle
 21：     
 22：     ' DataObj.Customer，Bill，Slipの実体化
 23：     Set objDataCustomer = CreateObject("DataObj.Customer")
 24：     Set objDataBill = CreateObject("DataObj.Bill")
 25：     Set objDataSlip = CreateObject("DataObj.Slip")
 26：     
 27：     ' 削除対象となる顧客が伝票ならびに請求書で使われていないことを確認
 28：     If objDataBill.IsExistsCustomer(ID) Or _
  　           objDataSlip.IsExistsCustomer(ID) Then
 29：         ' 存在している
 30：         Err.Raise Err_CANTDELETE, App.Title, _
   　                   "伝票か請求書が存在するため削除できません"
 31：     End If
 32：     
 33：     ' 現在の顧客の状態を確認
 34：     Select Case objDataCustomer.IsDeleted(ID)
 35：         Case ID_Exists
 36：             ' 存在する
 37：             ' DELETEDFLAGフィールドの値をTrueにするだけ
 38：             objDataCustomer.SetDeletedFlag ID, True
 39：         Case ID_Deleted
 40：             ' 削除ずみ
 41：             ' SalesAdminロールかAllAdminロールに属していることを確認
 42：             If Not objContext.IsSecurityEnabled() Then
 43：                Err.Raise Err_NOSECURE, App.Title, _
  　                           "セキュリティ機構が無効です"
 44：             End If
 45：             ' SalesAdminロールまたはAllAdminロールに属しているか
 46：             If Not (objContext.IsCallerInRole("SalesAdmin") Or _
   　                  objContext.IsCallerInRole("AllAdmin")) Then
 47：                ' 属していない
 48：                 Err.Raise Err_CANTACCESS, App.Title, _
   　                           "削除権限がありません"
 49：             End If
 50：             ' レコードを本当に削除してしまう
 51：             objDataCustomer.DeleteRecord ID
 52：         Case ID_NotFound
 53：             ' 存在しない
 54：              Err.Raise DataObj.Err_NotFound, App.Title, _
   　                        "指定された顧客番号をもつ顧客が見つかりません"
 55：     End Select
 56：     
 57：     ' DataObj.Customer，Bill，Slipの解放
 58：     Set objDataSlip = Nothing
 59：     Set objDataBill = Nothing
 60：     Set objDataCustomer = Nothing
 61：     
 62：     ' コミットする
 63：     objContext.SetComplete
 64：     
 65：     ' オブジェクトコンテキストの解放
 66：     Set objContext = Nothing
 67：     
 68：     Exit Sub
 69： 
 70： ErrHandle:
 71：     ' エラーハンドラ
 72：     objContext.SetAbort
 73：     Set objContext = Nothing
 74：     Set objDataCustomer = Nothing
 75：     Set objDataBill = Nothing
 76：     Set objDataSlip = Nothing
 77：     
 78：     ' エラーの再発行
 79：     Err.Raise Err.Number, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
 80： End Sub