DAO3.6　トランザクション処理を含んだサンプル


VB Tips And Sample（HOME）＞(戻る)

フォームのコード

VERSION　5.00
Begin　VB.Form　Form1　
　　　Caption　　　　　　　　　=　　　"Form1"
　　　ClientHeight　　　　=　　　2640
　　　ClientLeft　　　　　　=　　　60
　　　ClientTop　　　　　　　=　　　345
　　　ClientWidth　　　　　=　　　6825
　　　LinkTopic　　　　　　　=　　　"Form1"
　　　ScaleHeight　　　　　=　　　2640
　　　ScaleWidth　　　　　　=　　　6825
　　　StartUpPosition　=　　　3　　'Windows　の既定値
 　　　Begin　VB.CommandButton　Command1　
　　　　　　Caption　　　　　　　　　=　　　"DAO3.6"
　　　　　　Height　　　　　　　　　　=　　　795
　　　　　　Left　　　　　　　　　　　　=　　　2220
　　　　　　TabIndex　　　　　　　　=　　　0
　　　　　　Top　　　　　　　　　　　　　=　　　840
　　　　　　Width　　　　　　　　　　　=　　　2475
　　　End
End
Attribute　VB_Name　=　"Form1"
Attribute　VB_GlobalNameSpace　=　False
Attribute　VB_Creatable　=　False
Attribute　VB_PredeclaredId　=　True
Attribute　VB_Exposed　=　False
Option　Explicit
'DAO3.6　を参照設定
 'DAO3.6の場合はAccess97　2000両方とも扱える
Private　Sub　Command1_Click()
'DAOを使用してｍｄｂを更新処理
 'トランザクション処理を使用
 On　Error　GoTo　SOS
　　
　　Dim　RS　As　DAO.Recordset

　　If　GF_DbOpen　＜＞　0　Then　'規定のワークスペースを使ってデータベースを開く
 　　　　　'エラー発生の為終了
 　　　　　　Call　GS_DAO_End　'データベースを閉じる
 　　　　　　Exit　Sub
　　End　If
　　
　　G_Wsdao.BeginTrans　'トランザクションの開始
 　　
　　
　　If　GF_RsOpen(RS,　"select　*　from　テーブル1")　=　0　Then
　　　　'レコードセットオープンの成功
 　　　　RS.Edit　　'更新
 　　　　RS.Fields("AA").Value　=　"A"
　　　　RS.Update
　　　　G_Wsdao.CommitTrans　'トランザクションコミット
 　　　　Call　GS_RsClose(RS)　　'レコードセットを閉じる
 　　　　
　　Else
　　　　'レコードセットオープンに失敗した場合
 　　　　G_Wsdao.Rollback　'ロールバックするとrsオブジェクトが　中途半端に削除される
 '　　　　If　RS　Is　Nothing　Then
 '　　　　　　　MsgBox　""
 '　　　　Else
 '　　　　　　　Debug.Print　RS.RecordCount
 '　　　　End　If
 　　　　Call　GS_RsClose(RS)　　'レコードセットを閉じる
 　　　　Call　GS_DAO_End　'データベースを閉じる
 　　　　Exit　Sub
　　End　If
　　
　　

　　Call　GS_DAO_End　'データベースを閉じる
''''Open　App.Path　&　"\結果.txt"　For　Output　As　#1
 '''''　他のモードで開く前に、このファイルを一度閉じます。
 ''''　　　Print　#1,　"DAO3.6　OK"
 ''''
 ''''Close　#1
 ''''Dim　strpath
 ''''strpath　=　"　"　&　App.Path　&　"\結果.txt"
 ''''ret　=　Shell("notepad.exe"　&　strpath,　vbNormalFocus)

Exit　Sub
SOS:

　　　MsgBox　Err.Description,　vbCritical
　　　Err.Clear
　　　
'On　Error　GoTo　0　'これを書いても以下の処理On　Error　Resume　Nextは有効にならない無駄
 'On　Error　Resume　Next　　'エラーは無視　error処理の中のこの処理は無効らしい？？
　　　G_Wsdao.Rollback　'ロールバックするとrsオブジェクトが　中途半端に削除される
 　　　Call　GS_RsClose(RS)　　'レコードセットを閉じる
 　　　Call　GS_DAO_End　'データベースを閉じる
 　　　Err.Clear　'エラーのクリア
End　Sub




標準モジュール

Attribute　VB_Name　=　"DB_DAO"
Option　Explicit

Public　G_Wsdao　As　DAO.Workspace　'DAOワークスペース
 Public　G_Dbdao　As　DAO.Database　'DAOデータベース
Public　Function　GF_DbOpen()　As　Long
'ここから始まる
 On　Error　GoTo　SOSGF_DbOpen

　　　　Set　G_Wsdao　=　DBEngine.Workspaces(0)　'規定のワークスペース
 '　　　　既定のワークスペース
 '　　アプリケーションから初めて　DAO　オブジェクトを参照した場合に、
 '　　DAO　によって自動的に作成される　Workspace　オブジェクトです。
 '　　この　Workspace　は、DBEngine.Workspaces(0)、または単に　Workspaces(0)　と記述することにより参照できます。
　　　　Set　G_Dbdao　=　G_Wsdao.OpenDatabase(App.Path　&　"\test.mdb")　　　　'　データベースオープン
　　　　GF_DbOpen　=　0　'エラーなし
 　　　　Exit　Function

SOSGF_DbOpen:
　　　　
　　　　MsgBox　Err.Description,　vbCritical,　"GF_DbOpenデータベースエラー"
　　　　GF_DbOpen　=　Err.Number　'エラーナンバーを返す
 　　　　Err.Clear　　'エラーをクリアする
End　Function

'　　レコードセットOpen　
 Public　Function　GF_RsOpen(ByRef　RS　As　DAO.Recordset,　ByVal　Sql　As　String)　As　Long

On　Error　GoTo　SOSGF_RsOpen

　　　　Set　RS　=　G_Dbdao.OpenRecordset(Sql,　dbOpenDynaset)
　　　
　　　　GF_RsOpen　=　0　'エラーなし
 　　　　Exit　Function

SOSGF_RsOpen:
　　　　
　　　　MsgBox　Err.Description,　vbCritical,　"GF_RsOpenデータベースエラー"
　　　　GF_RsOpen　=　Err.Number　'エラーナンバーを返す
 　　　　Err.Clear　　'エラーをクリアする
 　　　　
End　Function
'　　レコードセットClose　
 Public　Sub　GS_RsClose(ByRef　RS　As　DAO.Recordset)
On　Error　Resume　Next　'これを書いておかないとエラーの場合呼び出し元のエラー処理に入ってしまう
 　　　　RS.Close
　　　　Set　RS　=　Nothing
　　Err.Clear　'エラーをクリアしておく
 End　Sub

'　　終了処理
Public　Sub　GS_DAO_End()
On　Error　Resume　Next　'これを書いておかないとエラーの場合呼び出し元のエラー処理に入ってしまう
 　　　　G_Dbdao.Close　　'　データベースクローズ
 　　　　G_Wsdao.Close　　'　ワークスぺースクローズ
 　　　　Set　G_Dbdao　=　Nothing
　　　　Set　G_Wsdao　=　Nothing
　　Err.Clear　'エラーをクリアしておく
 End　Sub




© 　2004　I Love Balard. All Rights Reserved.
VB Tips And Sample（HOME）＞(戻る)