はじめに
これは、Visual Basic Advent Calendar 2024 の6日目の記事です。
VBAで、ADODB（Microsoft ActiveX Data Objects）を使っていると、コネクションやレコードセットをCloseするのを忘れないように気を使います。
そんな余計な気遣いを解消するために作ったのが、今回ご紹介するAdoConnectionクラスです。
AdoConnectionクラス
以下がコードになります。
使用時に設定が必要なのは、冒頭のcnString定数です。接続文字列を設定しますが、ここではDSNファイルのファイルパスにしています。
AdoConnection.cls
Option Explicit
Private Const cnString As String = "{フォルダパス}\{DSNファイル名}.dsn"
Private cn As ADODB.Connection
Private rsBox As Collection
' インスタンス作成時に呼ばれる
Private Sub Class_Initialize()
On Error GoTo Catch
If cn Is Nothing Then Set cn = New ADODB.Connection
cn.ConnectionString = cnString
' 既定値30秒を120秒に変更
cn.CommandTimeout = 120
Exit Sub
Catch:
OutputError "AdoConnection.Class_Initialize"
End Sub
' コネクションを開く
Public Sub OpenConnection()
If cn.State = ObjectStateEnum.adStateClosed Then cn.Open
End Sub
' インスタンス解放時に呼ばれる
Private Sub Class_Terminate()
If Not rsBox Is Nothing Then
Dim rs As ADODB.Recordset
For Each rs In rsBox
If Not rs Is Nothing Then
If rs.State = ObjectStateEnum.adStateOpen Then rs.Close
End If
Set rs = Nothing
Next
Set rsBox = Nothing
End If
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End Sub
' コネクションを取得する
Public Property Get ActiveConnection() As ADODB.Connection
Set ActiveConnection = cn
End Property
' ExecuteScalarの実行
Public Function ExecuteScalar(ByVal sql As String) As Variant
On Error GoTo Catch
Call OpenConnection
Dim rs As ADODB.Recordset: Set rs = cn.Execute(sql)
If rs.EOF Then
ExecuteScalar = Empty
Else
ExecuteScalar = xNz(rs.Fields(0).Value)
End If
GoTo Finally
Catch:
OutputError "AdoConnection.ExecuteScalar", sql
ExecuteScalar = Empty
Finally:
If Not rs Is Nothing Then
If rs.State = ObjectStateEnum.adStateOpen Then rs.Close
End If
End Function
' ExecuteNonQueryの実行
Public Function ExecuteNonQuery(ByVal sql As String) As Long
On Error GoTo Catch
Dim rsCount As LongPtr
Call cn.Execute(sql, rsCount, adExecuteNoRecords)
ExecuteNonQuery = CLng(rsCount)
Exit Function
Catch:
OutputError "AdoConnection.ExecuteQuery", sql
ExecuteNonQuery = Empty
End Function
' フィールドのNullチェック用（AccessのNz関数をイメージ）
Public Function xNz(ByVal x As Variant, Optional ByVal vl As Variant = Empty) As Variant
On Error GoTo Catch
If IsNull(x) Then
xNz = vl
Else
xNz = x
End If
Exit Function
Catch:
OutputError "AdoConnection.xNz"
End Function
' レコードセットを返す
' オプション指定無しで実行すると非同期
Public Function GetRecordsetAsync(ByVal sql As String, _
Optional ByVal CursorType As ADODB.CursorTypeEnum = adOpenKeyset, _
Optional ByVal LockType As ADODB.LockTypeEnum = adLockOptimistic, _
Optional ByVal CursorLocation As CursorLocationEnum = adUseClient, _
Optional ByVal Options As ExecuteOptionEnum = adAsyncExecute) As ADODB.Recordset
Dim rs As New ADODB.Recordset
' adUseClientの場合、レコードセットがクライアント側のメモリに読み込まれる（高速になる）
rs.CursorLocation = CursorLocation
' cnが閉じていれば開く
Call OpenConnection
' レコードセットをオープン
Call rs.Open(sql, cn, CursorType, LockType, Options)
Set GetRecordsetAsync = rs
' レコードセットのコレクションに追加
If rsBox Is Nothing Then Set rsBox = New Collection
Call rsBox.Add(rs)
Set rs = Nothing
End Function
' レコードセットを返す
' 同期版
Public Function GetRecordset(ByVal sql As String, _
Optional ByVal CursorType As ADODB.CursorTypeEnum = adOpenKeyset, _
Optional ByVal LockType As ADODB.LockTypeEnum = adLockOptimistic, _
Optional ByVal CursorLocation As CursorLocationEnum = adUseClient) As ADODB.Recordset
Set GetRecordset = GetRecordsetAsync(sql, CursorType, LockType, CursorLocation, adOptionUnspecified)
End Function
' レコードセットをゼロベースの２次元配列に格納して返す
Public Function GetRows(ByVal rs As ADODB.Recordset) As Variant()
Dim rsCount As Long: rsCount = CLng(rs.RecordCount)
Dim fdCount As Long: fdCount = CLng(rs.Fields.Count)
If rsCount = 0 Then GoTo Finally
Dim arr() As Variant: ReDim arr(rsCount - 1, fdCount - 1)
Dim rw As Long
For rw = 0 To rsCount - 1
If rs.EOF Then Exit For
Dim cm As Long
For cm = 0 To fdCount - 1
arr(rw, cm) = xNz(rs.Fields(cm).Value)
Next
rs.MoveNext
Next
Finally:
GetRows = arr
End Function
' SQLでレコードセットを取得して、それをゼロベースの2次元配列に格納して返す
Public Function GetArray(ByVal sql As String, Optional ByRef WithColumnNames As Boolean = False) As Variant
Dim rs As New ADODB.Recordset
rs.CursorLocation = adUseClient
Call OpenConnection
Call rs.Open(sql, cn, adOpenForwardOnly, adLockReadOnly)
Dim rsCount As Long: rsCount = CLng(rs.RecordCount)
Dim fdCount As Long: fdCount = CLng(rs.Fields.Count)
Dim startIndex As Long
If WithColumnNames Then
startIndex = 1
Else
startIndex = 0
End If
If rsCount = 0 Then
GetArray = Empty
GoTo Finally
End If
Dim arr() As Variant
If WithColumnNames Then
ReDim arr(rsCount, fdCount - 1) As Variant
' カラム名をセット
Dim cm As Long
For cm = 0 To fdCount - 1
arr(0, cm) = rs.Fields(cm).Name
Next
Else
ReDim arr(rsCount - 1, fdCount - 1) As Variant
End If
Dim rw As Long
For rw = startIndex To rsCount + startIndex - 1
If rs.EOF Then Exit For
For cm = 0 To fdCount - 1
arr(rw, cm) = xNz(rs.Fields(cm).Value)
Next
rs.MoveNext
Next
Finally:
rs.Close
GetArray = arr
End Function
' エラーメッセージ出力
Private Sub OutputError(ByVal errPlace As String, Optional ByVal errNote As String)
Dim msg As String
msg = vbCrLf
msg = "DateTime : " & Format$(Now(), "yyyy-mm-dd hh:nn:ss") & vbCrLf
msg = msg & "Source : " & Err.Source & vbCrLf
msg = msg & "BookName : " & ActiveWorkbook.Name & vbCrLf
msg = msg & "Place : " & errPlace & vbCrLf
msg = msg & "Note : " & errNote & vbCrLf
msg = msg & "ErrNumber : " & Err.Number & vbCrLf
msg = msg & "ErrMessage : " & Err.Description & vbCrLf
Debug.Print msg
End Sub
使い方
Newしてクリエイトするだけです。後はほったらかし
Hoge.bas
Dim ado As New AdoConnection
Dim rs As ADODB.Recordset
Set rs = ado.GetRecordset("SELECT 列1 FROM テーブル1")
Do Until rs.EOF
Debug.Print ado.xNz(rs.Fields("列1").Value)
rs.MoveNext
Loop
NewしたSubやFunctionプロシージャを抜けるとAdoConnectionのClass_Terminateが呼ばれてレコードセットとコネクションが勝手にCloseされます。
再掲
' インスタンス解放時に呼ばれる
Private Sub Class_Terminate()
If Not rsBox Is Nothing Then
Dim rs As ADODB.Recordset
For Each rs In rsBox
If Not rs Is Nothing Then
If rs.State = ObjectStateEnum.adStateOpen Then rs.Close
End If
Set rs = Nothing
Next
Set rsBox = Nothing
End If
If cn.State = adStateOpen Then cn.Close
Set cn = Nothing
End Sub
以上、まだまだ現役VBAの現場で役立つ便利ツールご紹介でした。
