Go to Qiita Advent Calendar 2024 Top
LoginSignup
1
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@jemm

VBAでDBにADO接続

Last updated at Posted at 2024-07-23

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

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

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クラスの作成

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クラスの作成

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

使用例

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がインストールされていない端末では最適化ができないので、バックアップのみ取得します。

1
1
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
1

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?