VBAでDBにADO接続

自分用の備忘録として。
他の記事なども参考にさせてもらっています。

## インターフェースクラス作成

``` vb:IDB
Option Explicit
'インターフェース

'**************************************************
'関数:Init
'
'引数
'   args:実装に応じてDB情報を渡す
'
'機能:DB初期設定
'**************************************************
Function Init(ByVal args As Variant)
End Function

'**************************************************
'関数:GetArray
'
'引数
'   select_sql:データを取得するSELECT文
'
'機能:DBからデータを取得(SELECT)
'**************************************************
Public Function GetArray(ByVal select_sql As String) As Variant
End Function

'**************************************************
'関数:ExecuteSql
'
'引数
'   any_sql:実行するsql文
'
'機能:SQLを実行する関数
'**************************************************
Public Function ExecuteSql(ByVal any_sql As String)
End Function

'**************************************************
'関数:DropTable
'
'引数
'   tableName:削除するテーブル名
'
'機能:テーブルが存在した場合、テーブル削除
'**************************************************
Public Function DropTable(ByVal tableName As String)
End Function
```

## Accessクラスの作成
``` vb:AccessDB
Option Explicit

Implements IDB ' インターフェース
Private db As String ' Accessファイルパス
Private bk As String ' バックアップAccessファイルパス
Private cn As Object
Private rs As Object
Private dbPath As String ' Accessファイルの格納フォルダ
Private lockDB As String ' Access使用中に生成されるロックファイルのパス

'***********************************************************************************************
' IDB_Init
'
' Param
'       args{Variant}:Accessファイルパス
'
' 機能:AccessDBに接続します。
'***********************************************************************************************
Function IDB_Init(ByVal args As Variant)
    Const PROVIDER As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" ' DBプロバイダー
    Dim dbBaseName As String ' 拡張子を除いたAccessファイル名
    Dim dbName As String ' Accessファイル名
    Dim bkName As String ' Accessバックアップファイル名
    Dim fso As Object
    
    db = args
    Set fso = CreateObject("Scripting.FileSystemObject")
    dbPath = fso.GetParentFolderName(db) ' パス
    dbName = fso.GetFileName(db) ' ファイル名
    dbBaseName = fso.GetBaseName(db) ' 拡張子除いたファイル名
    bkName = "BK_" & dbName ' バックアップファイル名
    bk = dbPath & "\" & bkName ' バックアップファイルパス
    lockDB = dbPath & "\" & dbBaseName & ".laccdb" ' ロックファイルパス
    Set fso = Nothing
    
    On Error GoTo ErrorHandler
    Set cn = New ADODB.Connection
    cn.Open PROVIDER & db
    Exit Function
ErrorHandler:
    MsgBox Err.Description & vbLf & "Accessファイルを確認してください。", vbCritical, "Code:" & Hex(Err.Number)
    End
End Function

'***********************************************************************************************
' IDB_GetArray
'
' Param
'    select_sql{String}:SELECT句
'
' Return
'        DBの検索結果を二次元配列で返します。
'
' 機能:DBからデータを取得
'***********************************************************************************************
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 '読み取り専用
    IDB_GetArray = rsToArray()
    GoTo finally
ErrorHandler:
    MsgBox Err.Description & vbLf & "データの取得時にエラーが発生しました。", vbCritical, "Code:" & Hex(Err.Number)
    End
finally:
    rs.Close: Set rs = Nothing
End Function

'***********************************************************************************************
' IDB_Execute
'
' Param
'   any_sql{String}:実行するSQL文
'
' 機能:SQLを実行(INSERTやDELETEなど）
'***********************************************************************************************
Public Function IDB_Execute(ByVal any_sql As String)
    On Error GoTo ErrorHandler
    cn.BeginTrans
    cn.Execute any_sql
    cn.CommitTrans
    Exit Function
ErrorHandler:
    cn.RollbackTrans
    MsgBox Err.Description & vbLf & "SQL実行に失敗しました。", vbCritical, "Code:" & Hex(Err.Number)
    End
End Function

'***********************************************************************************************
' IDB_DropTable
'
' Param
'   tableName{String}:削除するテーブル名
'
' 機能:テーブルを削除（DROP）します。存在しない場合のエラーを無視します。
'***********************************************************************************************
Public Function IDB_DropTable(ByVal tableName As String)
    On Error Resume Next ' 存在しない場合のエラーを無視します。
    cn.Execute "DROP TABLE " & tableName & ";"
    On Error GoTo 0
End Function

'***********************************************************************************************
' rsToArray
'
' Return
'       レコードセットを二次元配列で返す
'
' 機能:レコードセットを二次元配列に変換して返す
'***********************************************************************************************
Private Function rsToArray() As Variant
    On Error GoTo continue
    Dim rsArray As Variant
    ReDim rsArray(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 'フィールドの数だけ繰り返す
            rsArray(rsNum, fldNum) = rs(fldNum) '配列に格納
        Next fldNum
        rsNum = rsNum + 1 '縦要素をカウントアップする
        rs.MoveNext '次のレコードに移動する
    Loop
continue:
    rsToArray = rsArray
End Function

'***********************************************************************************************
'クラス破棄の処理
'***********************************************************************************************
Private Sub Class_Terminate()
    Dim dateSubtractValue As Date: dateSubtractValue = DateAdd("d", -1, Date) ' Accessファイルの最適化・バックアップ取得判定日付,常に最適化したい場合は0を設定
    
    cn.Close: Set cn = Nothing ' 切断・オブジェクト破棄
    
    If Dir(bk) = "" Then
        BackUpAndOptimizationDB
    ElseIf Format(FileDateTime(bk), "yyyy/mm/dd") <= dateSubtractValue Then ' Accessバックアップファイルが指定した日付よりも古い場合、最適化・バックアップを取得
        BackUpAndOptimizationDB
    End If
End Sub

'***********************************************************************************************
' BackUpAndOptimizationDB
'
' 機能:バックアップを取得し、AccessDBを最適化します。尚、Accessがインストールされていない端末は最適化できませんが、バックアップだけ取得します。
'***********************************************************************************************
Private Sub BackUpAndOptimizationDB()
    Dim dbApp As Object ' Accessアプリケーションオブジェクト

    On Error GoTo ErrorHandler
    ' Accessを開いてない（ロックファイルが存在しない）場合のみ、最適化・修復処理
    If Dir(lockDB) = "" Then
        ' BKファイルが既に存在する場合、削除
        If Dir(bk) <> "" Then
            Kill bk
        End If
        Name db As bk ' 元のAccessファイル名を変更してバックアップファイルとする
        Set dbApp = CreateObject("Access.Application") ' インストールされていない場合、エラー処理
        dbApp.DBEngine.CompactDatabase bk, db ' バックアップファイルを基に､元のAccessファイル名として最適化されたファイルを生成
        Set dbApp = Nothing
    End If
    Exit Sub
    
ErrorHandler:
    Debug.Print Err.Description
    ' Accessファイルが存在することを確認してBK生成
    If Dir(db) <> "" Then
        FileCopy db, bk
    ElseIf Dir(bk) <> "" Then
        FileCopy bk, db ' Accessファイルが存在せずBKファイルが存在する場合、BKファイルで元のAccessファイル名として複製
    End If
    On Error GoTo 0
End Sub
```

## SQLServerクラスの作成
``` vb:SQLServerDB
Option Explicit

Implements IDB ' インターフェース
Private rs As Object
Private cn As Object
'***************************************************************
' IDB_Init
'
' Param
'       args{Variant}:SQLServer接続情報
'
' 機能:SQLServerに接続します。
'***************************************************************
Function IDB_Init(ByVal args As Variant)
    On Error GoTo ErrorHandler
    Set cn = New ADODB.Connection
    
    cn.ConnectionString = "Provider=" & args(0) _
                        & ";Data Source=" & args(1) _
                        & ";Initial Catalog=" & args(2) _
                        & ";user id=" & args(3) _
                        & ";password=" & args(4)
    cn.Open
    Exit Function
ErrorHandler:
    MsgBox Err.Description & vbLf & "SQLServerの接続情報を確認してください。", vbCritical, "Code:" & Hex(Err.Number)
    End
End Function

'***************************************************************
' IDB_GetArray
'
' Param
'    select_sql{String}:SELECT句
'
' Return
'        DBの検索結果を二次元配列で返します。
'
' 機能:DBからデータを取得
'***************************************************************
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 ' 取得
    IDB_GetArray = rsToArray()
    GoTo finally
ErrorHandler:
    MsgBox Err.Description & vbLf & "データの取得時にエラーが発生しました。", vbCritical, "Code:" & Hex(Err.Number)
    End
finally:
    rs.Close: Set rs = Nothing
End Function

'***************************************************************
' IDB_Execute
'
' Param
'   any_sql{String}:実行するSQL文
'
' 機能:SQLを実行(INSERTやDELETEなど）
'***************************************************************
Public Function IDB_Execute(ByVal any_sql As String)
    On Error GoTo ErrorHandler
    cn.BeginTrans
    cn.Execute any_sql
    cn.CommitTrans
    Exit Function
ErrorHandler:
    cn.RollbackTrans
    MsgBox Err.Description & vbLf & "SQL実行に失敗しました。", vbCritical, "Code:" & Hex(Err.Number)
    End
End Function

'***************************************************************
' IDB_DropTable
'
' Param
'   tableName{String}:削除するテーブル名
'
' 機能:未実装
'***************************************************************
Public Function IDB_DropTable(ByVal tableName As String)
End Function

'***************************************************************
' rsToArray
'
' Return
'       レコードセットを二次元配列で返す
'
' 機能:レコードセットを二次元配列に変換して返す
'***************************************************************
Private Function rsToArray() As Variant
    On Error GoTo continue
    Dim rsArray As Variant
    ReDim rsArray(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 'フィールドの数だけ繰り返す
            rsArray(rsNum, fldNum) = rs(fldNum) '配列に格納
        Next fldNum
        rsNum = rsNum + 1 '縦要素をカウントアップする
        rs.MoveNext '次のレコードに移動する
    Loop
continue:
    rsToArray = rsArray
End Function

'***************************************************************
'クラス破棄の処理
'***************************************************************
Private Sub Class_Terminate()
    cn.Close
    Set cn = Nothing
End Sub
```

## 使用例
``` vb:example
Dim accessPath As String ' Accessファイルのパス指定
Dim sqlsvrCon() As Variant ' SQLServer接続情報の配列
Dim access As IDB ' AccessDBオブジェクト
Dim sqlsvr As IDB ' SQLServerDBオブジェクト

' 接続情報を変数に格納
accessPath = ThisWorkbook.Path & "\Accessテスト用DB.accdb"
sqlsvrCon = Array("SQLOLEDB", ホスト名, DB名, ユーザ名, パスワード) ' ホスト名・DB名・ユーザ名・パスワードは自身の使用環境を文字列（ダブルクォーテーションで括る）で設定してください。

' インスタンス生成
Set access As New AccessDB
Set sqlsvr As New SqlServerDB

' 各DBに接続
access.Init(accessPath)
sqlsvr.Init(sqlsvrCon)

' データ取得(SELECT)
access.GetArray("SELECT * FROM hoge;")
sqlsvr.GetArray("SELECT * FROM foo;")

' データ更新や追加など
access.Execute("UPDATE hoge SET column = 'test';")
sqlsvr.Execute("UPDATE foo SET column = 'test';")

' テーブル削除
access.DropTable("DROP TABLE hoge;")
sqlsvr.DropTable("DROP TABLE foo;") ' 2024/7/23現在、私の方では不要だったので実装してません。時間あるときなどに更新します。。。すみません。

' DB切断
Set access = Nothing
Set sqlsvr = Nothing
```

AccessDBはクラス破棄のタイミング（DB切断）でバックアップを取得して、DBを最適化するようにしています。
本記事のソースではバックアップファイルが前日だった場合に実行します。お好みで変えてください。
ただし、Accessがインストールされていない端末では最適化ができないので、バックアップのみ取得します。