List 6-164 変更したBusiness.SlipコンポーネントのConsentSlipメソッド(変更部分は赤色で示した)
1: Public Sub ConsentSlip(ByVal SlipID As Long, _
ByVal Comment As Variant)
2: ' 指定された伝票を承認ずみにする
3: ' 【引数】
4: ' SlipID = 承認ずみとしたい伝票の伝票番号
5: ' Comment = 承認ずみにするときのコメント
6: ' 【戻り値】
7: ' なし
8: Dim objContext As ObjectContext
9: Dim objDataSlip As DataObj.Slip
10: Dim objDataSlipDetail As DataObj.SlipDetail
11: Dim objDataSlipInformation As DataObj.SlipInformation
12: Dim objDataStock As DataObj.STOCK
13: Dim objRecSlipDetail As ADODB.Recordset
14: Dim SlipStatus As SlipStatus
15: Dim old_MADEDATE As Variant, old_MADEUSER As Variant
16: Dim old_LASTUSER As Variant, old_LASTDATE As Variant
17: Dim old_DIVISION As Variant, old_PERSON As Variant, old_DELIVERDATE As Variant
18: Dim old_SENT_ADDR As Variant, old_SENT_TEL As Variant, old_MEMO As Variant
19: Dim old_CUSTOMERID As Variant, old_SUBTOTAL As Variant, old_TAX As Variant
20: Dim old_TOTAL As Variant
21:
22: ' オブジェクトコンテキストの取得
23: Set objContext = GetObjectContext()
24:
25: ' エラーハンドラの設定
26: On Error GoTo ErrHandle
27:
28: ' DataObj.Slipコンポーネントを実体化
29: Set objDataSlip = CreateObject("DataObj.Slip")
30:
31: ' 伝票が存在することを確認
32: If objDataSlip.IsDeleted(SlipID) <> ID_Exists Then
33: ' 伝票が存在しない
34: Err.Raise Errorcode.Err_NOTFOUND, App.Title, _
35: "指定された伝票は存在しません"
36: End If
37:
38: ' 伝票の状態を取得
39: SlipStatus = objDataSlip.Get_SlipStatus(SlipID)
40: If (SlipStatus <> RequestingConsent) Then
41: ' 伝票が承認依頼中ではない
42: Err.Raise BusinessError.Err_CANTUPDATE, App.Title, _
"その伝票は承認依頼中ではありません"
43: End If
44:
45: ' 権限の確認
46: If Not objContext.IsSecurityEnabled() Then
47: ' セキュリティ設定が無効
48: Err.Raise ERR_NOSECURE, App.Title, _
"セキュリティ機構が無効です"
49: End If
50: ' 伝票の状態を取得
51: objDataSlip.GetRecord_Slip SlipID, old_CUSTOMERID, _
old_SUBTOTAL, old_TAX, _
old_TOTAL, old_MADEDATE, _
old_MADEUSER, old_LASTDATE, _
old_LASTUSER
52: If (objContext.Security.GetOriginalCallerName <> old_MADEUSER) Or _
(old_TOTAL > g_MaxTotal) Then
53:
54: If Not (objContext.IsCallerInRole("SalesManager") Or _
objContext.IsCallerInRole("SalesAdmin") Or _
objContext.IsCallerInRole("AllAdmin")) Then
' SalesManager,SalesAdmin,AllAdminのいずれのロールにも属さない
55: Err.Raise ERR_NOSECURE, App.Title, _
"承認ずみにする権限がありません"
56: End If
57: End If
58:
59: ' CONSENTEDFLAGフィールドの値をTrueにする
60: objDataSlip.Set_CONSENTEDFLAG SlipID, True, Comment
61: ' REQ_CONSENTFLAGフィールドの値をFalseにする
62: objDataSlip.Set_REQ_CONSENTFLAG SlipID, False, Null
63:
64: ' 伝票追加情報を取得し,納入予定日を得る
65: ' DataObj.SlipInformationコンポーネントの実体化
66: Set objDataSlipInformation = CreateObject("DataObj.SlipInformation")
67: objDataSlipInformation.GetRecord SlipID, old_DIVISION, _
old_PERSON, old_DELIVERDATE, _
old_SENT_ADDR, old_SENT_TEL, old_MEMO, _
old_MADEDATE, old_MADEUSER, _
old_LASTDATE, old_LASTUSER
68:
69: ' 明細レコードの取得
70: ' DataObj.SlipDetailコンポーネントの実体化
71: Set objDataSlipDetail = CreateObject("DataObj.SlipDetail")
72: Set objRecSlipDetail = objDataSlipDetail.GetRecords(SlipID)
73:
74: ' DataObj.Stockコンポーネントの実体化
75: Set objDataStock = CreateObject("DataObj.Stock")
76:
77: ' すべての明細についてループ
78: While Not objRecSlipDetail.EOF
79: If Not objRecSlipDetail.Fields("DELETEDFLAG").Value Then
80: ' 在庫情報テーブルに出庫情報を追加する
81: objDataStock.AddRecord old_DELIVERDATE, _
objRecSlipDetail.Fields("PRODUCTID").Value, _
-objRecSlipDetail.Fields("NUMBER").Value, _
objRecSlipDetail.Fields("MEMO").Value, _
SlipID
82: End If
83:
84: ' 次のレコードに移動
85: objRecSlipDetail.MoveNext
86: Wend
87:
88: objRecSlipDetail.Close
89: Set objRecSlipDetail = Nothing
90:
91: ' 各種コンポーネントの解放
92: Set objDataStock = Nothing
93: Set objDataSlipDetail = Nothing
94: Set objDataSlipInformation = Nothing
95: Set objDataSlip = Nothing
96:
97: ' トランザクションのコミット
98: objContext.SetComplete
99:
100: ' オブジェクトコンテキストの解放
101: Set objContext = Nothing
102:
103: Exit Sub
104:
105: ErrHandle:
106: ' エラーハンドラ
107: objContext.SetAbort
108: Set objDataSlip = Nothing
109: Set objDataSlipInformation = Nothing
110: Set objDataSlipDetail = Nothing
111: Set objDataStock = Nothing
112: Set objRecSlipDetail = Nothing
113:
114: ' エラーの再発行
115: Err.Raise Err.Number, Err.Source, Err.Description, _
Err.HelpFile, Err.HelpContext
116: End Sub