VBAでDBを操作するならこれを使え！


# はじめに
アプリケーションを作成する際、DB操作からは逃げることができません。
私はよくExcel VBA で Access を DB とした業務ツールを作成しています。

DB操作を行うコードを書くことに飽き飽きしてきた今日この頃。

気づいたら、DB操作の汎用コードを作成してしまいました。
せっかくなので、DB操作の汎用コードを公開します(^^)/

# ☆注意☆
業務ツールで何度も使用しているので、基本的に問題なく動くと思いますが、
ご使用は自己責任でお願いいたします。
不具合などがあった場合も、損害について補償は一切できませんので、あらかじめご了承ください。


# DB操作汎用コード
クラスモジュールで実装してます。
今はAccessのみの実装となります。

### それではまずインターフェース
```vb:IDB
Option Explicit

' **
' * DBの初期設定を行う関数
' *
' * @param {Variant}   args   実装に合わせて自由な引数を渡す
' *
' *
Function Init(ByVal args As Variant)
End Function

' **
' * DBからデータを配列で取得する関数
' *
' * @param {String}   select_sql   データを取得するためのSELECT文
' *
' *
Public Function GetArray(ByVal select_sql As String) As Variant
End Function

' **
' * SQLを実行する関数
' *
' * @param {String}   any_sql   実行したいSQL文
' *
' *
Public Function ExecuteSQL(ByVal any_sql As String) 
End Function

' **
' * DBに配列データをINSERTする関数
' *
' * @param {String}   select_sql   INSERTする対象を取得するSELECT文
' * @param {Variant}   datas   INSERTしたい配列データ（２次元配列）
' *
' *
Public Function InsertByArray(ByVal select_sql As String, ByVal datas As Variant) 
End Function

' **
' * DBに配列データをUPDATEする関数
' *
' * @param {String}   select_sql   UPDATEする対象を取得するSELECT文
' * @param {Variant}   datas   UPDATEしたい配列データ（２次元配列）
' * @param {Variant}   keys   UPDATEしたい配列データの主キーの位置情報（1次元配列）
' *
' *
Public Function UpdateByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
End Function

' **
' * DBに配列データをMERGEする関数
' *
' * @param {String}   select_sql   MERGEする対象を取得するSELECT文
' * @param {Variant}   datas   MERGEしたい配列データ（２次元配列）
' * @param {Variant}   keys   UPDATEしたい配列データの主キーの位置情報（1次元配列）
' *
' *
Public Function MergeByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
End Function

```

### 次に実装クラス
※ADODBを使用していますので、ADODBへの参照設定（Microsoft ActiveX Data Objects x.x Library）を行ってください。

```vb:DB_Access
Option Explicit

Implements IDB

Private my_db As String
Private RS As Object
Private CN As Object

'Accessの実装なのでAccessファイルパスをセットします。
Function IDB_Init(ByVal args As Variant)
    On Error GoTo ErrorHandler
    my_db = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & args
    Set CN = New ADODB.Connection
    CN.Open my_db
    Exit Function
ErrorHandler:
    Err.Raise 8000, Err.Source, Join(Array("DBが見つかりません。", vbLf, Err.Description), "")
End Function


Public Function IDB_GetArray(ByVal select_sql As String) As Variant
    On Error GoTo ErrorHandler
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockReadOnly ' 2023/01/24 読み取り専用に改修
    IDB_GetArray = RSToArray()
    GoTo finally
ErrorHandler:
    Err.Raise 8005, Err.Source, Join(Array("データの取得に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_ExecuteSQL(ByVal any_sql As String) 
    On Error GoTo ErrorHandler
    CN.BeginTrans
    CN.Execute any_sql
    CN.CommitTrans
    
    Exit Function
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8010, Err.Source, Join(Array("SQLの実行に失敗しました", vbLf, Err.Description), "")
End Function


Public Function IDB_InsertByArray(ByVal select_sql As String, ByVal datas As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Dim i As Long, j As Long
    For i = 1 To UBound(datas, 1)
        RS.AddNew
        For j = 1 To RS.fields.count
            RS(j - 1) = datas(i, j)
        Next j
        RS.Update
    Next i
    CN.CommitTrans
    
    GoTo finally
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8015, Err.Source, Join(Array("データの挿入に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_UpdateByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Call GoUpdate(datas, keys)
    CN.CommitTrans
    
    GoTo finally
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8020, Err.Source, Join(Array("データの更新に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


Public Function IDB_MergeByArray(ByVal select_sql As String, ByVal datas As Variant, ByVal keys As Variant) 
    Set RS = New ADODB.Recordset
    RS.Open select_sql, CN, adOpenKeyset, adLockOptimistic
    
    On Error GoTo ErrorHandler
    CN.BeginTrans
    Call GoMerge(datas, keys)
    CN.CommitTrans
    
    GoTo finally
    
ErrorHandler:
    CN.RollbackTrans
    Err.Raise 8025, Err.Source, Join(Array("データの追加更新に失敗しました", vbLf, Err.Description), "")
finally:
    Set RS = Nothing
End Function


'Accessの更新を行う内部ロジック
Private Function GoUpdate(ByVal datas As Variant, ByVal keys As Variant)
    With RS
        Dim i As Long
        Dim j As Long
        Dim filters As Variant
        ReDim filters(UBound(keys))
        
        Dim diff As Long: diff = LBound(datas, 2)
        
        For i = LBound(datas, 1) To UBound(datas, 1)
            'フィルター
            For j = LBound(keys) To UBound(keys)
                filters(j) = Join(Array(RS(keys(j) - diff).name, datas(i, keys(j))), "='") & "'"
            Next j
            .Filter = Join(filters, " AND ")
            
            If .EOF Or .BOF Then    'UPDATE対象なし
                Err.Raise Number:=8021, Description:="更新対象データが見つかりません。ロールバックします。" & vbLf & "場所：配列datas(" & i & ")行目"
            Else    'UPDATE対象あり
                .MoveFirst
                While Not .EOF
                    For j = LBound(datas, 2) To UBound(datas, 2)
                        If Not (IsKey(keys, j)) Then RS(j - diff) = datas(i, j)
                    Next j
                    .Update
                    .MoveNext
                Wend
            End If
        Next i
    End With
End Function


'Accessの追加更新を行う内部ロジック
Private Function GoMerge(ByVal datas As Variant, ByVal keys As Variant)
    With RS
        Dim i As Long, j As Long
        Dim filters As Variant: ReDim filters(UBound(keys))
        Dim colCnt As Long: colCnt = RS.fields.count - 1
        Dim fieldList As Variant: ReDim fieldList(colCnt)
        Dim addList As Variant: ReDim addList(colCnt)
                
        For i = 0 To colCnt
            fieldList(i) = RS(i).name
        Next i
        
        Dim diff As Long: diff = LBound(datas, 2)
        
        For i = LBound(datas, 1) To UBound(datas, 1)
            'フィルター
            For j = LBound(keys) To UBound(keys)
                filters(j) = Join(Array(RS(keys(j) - diff).name, datas(i, keys(j))), "='") & "'"
            Next j
'            .MoveFirst
            .Filter = Join(filters, " AND ")
            
            If .EOF Or .BOF Then
                For j = LBound(datas, 2) To UBound(datas, 2)
                    addList(j - diff) = datas(i, j)
                Next j
                .AddNew fieldList, addList
                GoTo continue
            Else
                .MoveFirst
                While Not .EOF
                    For j = LBound(datas, 2) To UBound(datas, 2)
                        If Not (IsKey(keys, j)) Then RS(j - diff) = datas(i, j)
                    Next j
                    .Update
                    .MoveNext
                Wend
            End If
continue:
        Next i
    End With
End Function

'主キー判定内部ロジック
Private Function IsKey(ByVal keys As Variant, ByVal target As Variant) As Boolean
    Dim key As Variant
    For Each key In keys
        If target = key Then
            IsKey = True
            Exit For
        End If
    Next key
End Function



' レコードセットを配列に変換し、返却する内部ロジック
Private Function RSToArray() As Variant
    On Error GoTo continue
    Dim ary As Variant
    ReDim ary(RS.recordCount - 1, RS.fields.count - 1) '配列の要素数を定義
    Dim rsNum As Long '縦要素（レコードセット）の繰り返し用変数
    Dim fldNum As Long '横要素（フィールド）の繰り返し用変数
    RS.MoveFirst
    Do Until RS.EOF 'レコードセットが終了するまで処理を繰り返す
        For fldNum = 0 To RS.fields.count - 1 'フィールドの数だけ繰り返す
            ary(rsNum, fldNum) = RS(fldNum) '配列に格納
        Next fldNum
        rsNum = rsNum + 1 '縦要素をカウントアップする
        RS.MoveNext '次のレコードに移動する
    Loop
continue:
    RSToArray = ary
End Function

Private Sub Class_Terminate()
    If Not CN Is Nothing Then
        Set CN = Nothing
    End If
End Sub

```

# 使用例
```vb:Sample
Sub sample()
'    DBインスタンスを作成※IDBとしてインスタンス化
    Dim db As IDB
    Set db = New DB_Access
    
'    Accessファイルパスをセット
    Call db.Init("C:\Users\user\Desktop\sample.accdb")
    
'    データ取得使用例
    Dim datas As Variant
    datas = db.GetArray("SELECT * FROM SampleTBL")

'    SQL文実行例
    Call db.ExecuteSQL("DELETE FROM SampleTBL")
    
'    INSERT例
    datas = Range("A1:D5").Value
    Call db.InsertByArray("SELECT * FROM SampleTBL", datas)
    
'    UPDATE例(単独主キー)
    datas = Range("A1:D5").Value
    Call db.UpdateByArray("SELECT * FROM SampleTBL", datas, Array(1))
    
'    UPDATE例(複合主キー)
    datas = Range("A1:D5").Value
    Call db.UpdateByArray("SELECT * FROM SampleTBL", datas, Array(1, 2, 3))
    
'    MERGE例(単独主キー)
    datas = Range("A1:D5").Value
    Call db.MergeByArray("SELECT * FROM SampleTBL", datas, Array(1))
    
'    MERGE例(複合主キー)
    datas = Range("A1:D5").Value
    Call db.MergeByArray("SELECT * FROM SampleTBL", datas, Array(1, 2, 3))
    
End Sub
```


# 終わりに
使用方法についてかなり簡略的に書きましたが、ご質問などありましたら ***可能な限り***
お答えしますのでお知らせいただければと思います。

また、今後Access以外のDBを実装すつことがあれば同じように公開します。
この記事を読まれている***そこのあなた***が実装していただいても構いません。
その際はぜひ教えていただければと思います。

この汎用コードが誰かの力になりますように(*'ω'*)

以上、ここまでお付き合いいただきありがとうございました。