VBA SQL Serverに接続してトランザクションを設定する

VBA SQL Serverに接続してトランザクションを設定する

VBAで、SQL Serverに接続してトランザクションを設定するコードを記述してます。

環境

  • OS windows10 64bit

トランザクションを設定

実際に適当なボタンを用意して、「BeginTrans」でトランザクションを開始して、エラーがなければ「commit」され、エラーが発生すれば「Rollback」される
以下のソースコードを記述します。

DBは「sample」というDBで、テーブルは下図の列が定義された「Test」を使用します。

insetするセルデータは以下となります。

ソースコード

Option Explicit

Private Const PROVIDER As String = "SQLOLEDB"
Private Const DATA_SOURCE As String = "localhost"   'サーバ名
Private Const DATABASE As String = "sample" 'データベース名

'SQL Server認証で接続する場合
Private Const USER_ID As String = "sa"  'ユーザID
Private Const PASSWORD As String = "password"   'ユーザパスワード

Private Sub CommandButton1_Click()

On Error GoTo EXCEPTION_SECTION

Const PROCEDURE_NAME As String = "CommandButton1_Click"
    
    Dim strSQL As String
    Dim flg As Boolean
    Dim id As Long
    Dim i As Long
    Dim adoCn As Object
    Dim adoRs As Object
    
    '--------------------------------
    ' データベース接続
    '--------------------------------
    Set adoCn = CreateObject("ADODB.Connection")
    
    'SQL Server認証
    adoCn.ConnectionString = "Provider=" & PROVIDER _
                       & ";Data Source=" & DATA_SOURCE _
                       & ";Initial Catalog=" & DATABASE _
                       & ";UID=" & USER_ID _
                       & ";PWD=" & PASSWORD
    ' オープン
    adoCn.Open
    
    Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクト
    
    ' トランザクション開始
    adoCn.BeginTrans
    
    With adoRs
    
        .Open "Test", adoCn, 1, 3 'レコードセットを開く(1:キーセットカーソル  3:レコードごとの共有的ロック)
    
        For i = 1 To Range("A1").End(xlDown).Row
        
            id = Cells(i, 1).Value
      
            ' 存在チェック
            flg = exitCheck(id, adoCn)
    
            ' 存在しなければ insertを実行
            If flg Then
        
                .AddNew
                    !id = id
                    !Name = Cells(i, 2).Value
                .Update
            
            End If
            
        Next i
        
        .Close 'レコードセットのクローズ
    
    End With
    
    ' コミット
    adoCn.CommitTrans
    
    GoTo EXIT_SECTION

EXCEPTION_SECTION:

    With Err
    
        ' エラー時はロールバック
        If .Number <> 0 Then adoCn.RollbackTrans

        MsgBox (.Description), vbOKOnly + vbExclamation + vbSystemModal, PROCEDURE_NAME

    End With

    GoTo EXIT_SECTION

EXIT_SECTION:

    ' レコードセットのクローズ
    If Not adoRs Is Nothing Then
        If adoRs.State = 1 Then adoRs.Close ' 開かれていればクローズ
        Set adoRs = Nothing
    End If
    
    ' データベースのクローズ
    If Not adoCn Is Nothing Then
        If adoCn.State = 1 Then adoCn.Close ' 開かれていればクローズ
        Set adoCn = Nothing
    End If
    
    MsgBox ("終了")

End Sub
' 存在チェック
Private Function exitCheck(ByVal id As Long, ByRef adoCn As Object) As Boolean

    Dim strSQL As String
    
    Dim adoRs As Object
    Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクト

    ' 存在チェック
    strSQL = "SELECT top(10) * FROM [sample].[dbo].[Test] where id =" & id
    
    adoRs.Open strSQL, adoCn 'レコード抽出
    
    exitCheck = adoRs.EOF ' フラグ
    
    adoRs.Close

End Function

実行後に、エラーが発生しなければ「commit」されて、データがinsertされていることが確認できます。

エラーが発生すると、「Rollback」されて、データは「insert」されません。

故意に、excelの5行目のデータ読み込んだ際に、エラーを発生させてみます。

    With adoRs
    
        .Open "Test", adoCn, 1, 3 'レコードセットを開く(1:キーセットカーソル  3:レコードごとの共有的ロック)
    
        For i = 1 To Range("A1").End(xlDown).Row
        
            id = Cells(i, 1).Value
      
            ' 存在チェック
            flg = exitCheck(id, adoCn)
    
            ' 存在しなければ insertを実行
            If flg Then
        
                .AddNew
                    !id = id
                    !Name = Cells(i, 2).Value
                .Update
            
            End If
            
           ' エラーを発生
            If i = 5 Then Err.Raise 1
            
        Next i
        
        .Close 'レコードセットのクローズ
    
    End With

1件もデータが「insert」されていないことが確認できます。