List 6-92　DataObj.SlipInformationコンポーネントのAddRecordメソッド

  1： Private Sub Chk_SLIPID(ByRef SlipID As Variant)
  2：     ' 伝票番号が正しいかどうかを調べる
  3：     If IsNull(SlipID) Then
  4：         Err.Raise Errorcode.Err_SLIPID, App.Title, _
   　                   "伝票番号が不正です"
  5：     Else
  6：         If Not IsNumeric(SlipID) Then
  7：             Err.Raise Errorcode.Err_SLIPID, App.Title, _
   　                       "伝票番号が有効な数字ではありません"
  8：         End If
  9：     End If
 10： End Sub
 11： 
 12： Private Sub Chk_DIVISION(ByRef DIVISION As Variant)
 13：     ' 顧客の担当部署名が正しいかどうかを調べる
 14：     If Not IsNull(DIVISION) Then
 15：         If Len(DIVISION) > 64 Then
 16：             Err.Raise Errorcode.Err_DIVISION, App.Title, _
   　                       "担当部署名が長すぎます"
 17：         End If
 18：     End If
 19： End Sub
 20： 
 21： Private Sub Chk_PERSON(ByRef PERSON As Variant)
 22：     ' 顧客の担当者名が正しいかどうかを調べる
 23：     If Not IsNull(PERSON) Then
 24：         If Len(PERSON) > 64 Then
 25：             Err.Raise Errorcode.Err_PERSON, App.Title, _
   　                       "担当者名が長すぎます"
 26：         End If
 27：     End If
 28： End Sub
 29：
 30： Private Sub Chk_DELIVERDATE(ByRef DELIVERDATE As Variant)
 31：     ' 納入予定日が正しいかどうかを調べる
 32：     If IsNull(DELIVERDATE) Then
 33：         Err.Raise Errorcode.Err_DELIVERDATE, App.Title, _
   　                   "納入予定日が設定されていません"
 34：     Else
 35：         If Not IsDate(DELIVERDATE) Then
 36：             Err.Raise Errorcode.Err_DELIVERDATE, App.Title, _
   　                       "納入予定日が不正です"
 37：         End If
 38：     End If
 39： End Sub
 40：
 41： Private Sub Chk_SENT_ADDR(ByRef SENT_ADDR As Variant)
 42：     ' 発送先が正しいかどうかを調べる
 43：     If Not IsNull(SENT_ADDR) Then
 44：         If Len(SENT_ADDR) > 255 Then
 45：             Err.Raise Errorcode.Err_SENT_ADDR, App.Title, _
   　                       "発送先が長すぎます"
 46：         End If
 47：     End If
 48： End Sub
 49：
 50： Private Sub Chk_SENT_TEL(ByRef SENT_TEL As Variant)
 51：     ' 発送先の電話番号が正しいかどうかを調べる
 52：     If Not IsNull(SENT_TEL) Then
 53：         If Len(SENT_TEL) > 32 Then
 54：             Err.Raise Errorcode.Err_SENT_TEL, App.Title, _
   　                       "発送先電話番号が長すぎます"
 55：         End If
 56：     End If
 57： End Sub
 58：
 59： Private Sub Chk_MEMO(ByRef MEMO As Variant)
 60：     ' 摘要が正しいかどうかを調べる
 61：     If Not IsNull(MEMO) Then
 62：         If Len(MEMO) > 80 Then
 63：             Err.Raise Errorcode.Err_MEMOTOOLONG, App.Title, _
   　                       "摘要は80文字以内でなければなりません"
 63：         End If
 64：     End If
 65： End Sub
 66：
 67： Public Function AddRecord(ByVal SlipID As Variant, _
   　                           ByVal DIVISION As Variant, _
   　                           ByVal PERSON As Variant, _
   　                           ByVal DELIVERDATE As Variant, _
   　                           ByVal SENT_ADDR As Variant, _
   　                           ByVal SENT_TEL As Variant, _
   　                           ByVal MEMO As Variant) As Long
 68：     ' 伝票追加情報テーブルに新しいレコードを加える
 69：     ' 【引数】
 70：     '   SlipID = 結び付ける伝票の伝票番号
 71：     '   DIVISION = 顧客の部署名
 72：     '   PERSON = 顧客の担当者名
 73：     '   DELIVERDATE = 納入予定日
 74：     '   SENT_ADDR = 発送先の住所
 75：     '   SENT_TEL = 発送先の電話番号
 76：     '   MEMO = 摘要
 77：     Dim objContext As ObjectContext
 78：     Dim objRec As ADODB.Recordset
 79：     Dim userName As String, NowDate As Date
 80：     
 81：     ' オブジェクトコンテキストの取得
 82：     Set objContext = GetObjectContext()
 83：     
 84：     ' エラーハンドラの設定
 85：     On Error GoTo ErrHandle
 86：     
 87：     ' ユーザー名とその時点の時刻を取得
 88：     userName = objContext.Security.GetOriginalCallerName()
 89：     NowDate = Now()
 90：     
 91：     ' 与えられた引数が正しいかどうかをチェック
 92：     Chk_SLIPID SlipID
 93：     Chk_DIVISION DIVISION
 94：     Chk_PERSON PERSON
 95：     Chk_DELIVERDATE DELIVERDATE
 96：     Chk_SENT_ADDR SENT_ADDR
 97：     Chk_SENT_TEL SENT_TEL
 98：     Chk_MEMO MEMO
 99：    
100：     ' データベースと接続し，書き込み可能なレコードセットを取得
101：     Set objRec = CreateObject("ADODB.Recordset")
102：     objRec.Open "伝票追加情報", g_DBConnection, adOpenKeyset, _
   　                  adLockPessimistic, adCmdTable
103：                
104：     ' 新しいレコードを追加
105：     objRec.AddNew
106：    
107：     ' レコードにデータを設定
108：     objRec.Fields("SLIPID").Value = SlipID
109：     objRec.Fields("DIVISION").Value = DIVISION
110：     objRec.Fields("PERSON").Value = PERSON
111：     objRec.Fields("DELIVERDATE").Value = DELIVERDATE
112：     objRec.Fields("SENT_ADDR").Value = SENT_ADDR
113：     objRec.Fields("SENT_TEL").Value = SENT_TEL
114：     objRec.Fields("MEMO").Value = MEMO
115：     objRec.Fields("MADEDATE").Value = NowDate
116：     objRec.Fields("LASTDATE").Value = NowDate
117：     objRec.Fields("MADEUSER").Value = userName
118：     objRec.Fields("LASTUSER").Value = userName
119：     objRec.Fields("DELETEDFLAG").Value = False
120：     
121：     ' データベースに反映
122：     objRec.Update
123：     
124：     ' 追加した伝票追加情報のレコードIDを戻り値として設定
125：     AddRecord = objRec.Fields("ID").Value
126：     
127：     ' データベースとの接続を閉じてレコードセットを解放
128：     objRec.Close
129：     Set objRec = Nothing
130：     
131：     ' トランザクションをコミット
132：     objContext.SetComplete
133：     
134：     ' オブジェクトコンテキストの解放
135：     Set objContext = Nothing
136：     
137：     Exit Function
138：     
139： ErrHandle:
140：     ' エラーハンドラ
141：     objContext.SetAbort
142：    
143：     Set objContext = Nothing
144：     Set objRec = Nothing
145：    
146：     ' エラーの再発行
147：     Err.Raise Err.NUMBER, Err.Source, Err.Description, _
   　               Err.HelpFile, Err.HelpContext
148： End Function