やっといて！AdoConnectionクラス

はじめに
---
これは、[Visual Basic Advent Calendar 2024](https://qiita.com/advent-calendar/2024/vb)	の6日目の記事です。

VBAで、`ADODB`（Microsoft ActiveX Data Objects）を使っていると、コネクションやレコードセットを`Close`するのを忘れないように気を使います。
そんな余計な気遣いを解消するために作ったのが、今回ご紹介する`AdoConnection`クラスです。


`AdoConnection`クラス
---
以下がコードになります。
使用時に設定が必要なのは、冒頭の`cnString`定数です。接続文字列を設定しますが、ここではDSNファイルのファイルパスにしています。

```vb: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`してクリエイトするだけです。後はほったらかし:grin:
```vb: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`されます。

```vb:再掲
' インスタンス解放時に呼ばれる
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の現場で役立つ便利ツールご紹介でした。:snowman2::christmas_tree::snowman2::christmas_tree::snowman2::christmas_tree::snowman2::christmas_tree: