はじめに
アプリケーションを作成する際、DB操作からは逃げることができません。
私はよくExcel VBA で Access を DB とした業務ツールを作成しています。
DB操作を行うコードを書くことに飽き飽きしてきた今日この頃。
気づいたら、DB操作の汎用コードを作成してしまいました。
せっかくなので、DB操作の汎用コードを公開します(^^)/
☆注意☆
業務ツールで何度も使用しているので、基本的に問題なく動くと思いますが、
ご使用は自己責任でお願いいたします。
不具合などがあった場合も、損害について補償は一切できませんので、あらかじめご了承ください。
DB操作汎用コード
クラスモジュールで実装してます。
今はAccessのみの実装となります。
それではまずインターフェース
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）を行ってください。
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
使用例
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を実装すつことがあれば同じように公開します。
この記事を読まれているそこのあなたが実装していただいても構いません。
その際はぜひ教えていただければと思います。
この汎用コードが誰かの力になりますように('ω')
以上、ここまでお付き合いいただきありがとうございました。