【VBA】いまさらADO、されどADO

はじめに

これは、Visual Basic Advent Calendar 2022 の16日目の記事です。

VBAと共に生き続ける、ADO

ADO（ActiveX Data Objects）は、自分の記憶ではWindows95の時代から使い続けられている、VBAでSQL Serverなど、殆どのRDBを操作できる便利なCOMコンポーネントの一つだが、いまさら話題にもならず、知らない（知っていても見向きもしない）人もいるだろう。これは、ちょっと勿体ない。VBAでADOを使ってデータベースと戯れてみよう。

とにかく始める（SQL Server Expressのインストール）

まずは、SQL Server Expressのインストール。（ここでインストーラをダウンロード）
既にインストール済みの方は、この節は読み飛ばしてください。

SQL Server Expressのインストール

ダウンロードしたexeファイルをダブルクリック。

以下のウインドが現れたら、「基本」をクリック。デフォルトでWindows認証となるが、インストール時からSQL Server認証にしたい場合は「カスタム」をクリックすれば途中で設定できる。ここでは簡単な「基本」で進める。（インストール後に変更可能）

ライセンス条項を確認して、「同意する」をクリック。

「インストール」をクリック。

インストールパッケージのダウンロードが始まる、、

インストールが始まる、、

インストールが正常に完了したら、接続文字列をコピーする。（接続文字列の右横アイコンをクリック）「閉じる」をクリック。

「はい」をクリックしてインストール終了。

メモ帳などを開いてクリップボートの内容を貼り付ける。

ここで特に重要なのは、Server=localhost\SQLEXPRESS の部分だ。この後、このサーバー名が必要になる。（\は、Qiitaでは半角の￥マークが文字化けします。念のため）

sqlcmdでデータベースの作成

データベースの管理には、SQL Server Management Studio が便利だが、

ここではSQL Server Express（以下、SQLEXPRESSと言う）と同時にインストールされるsqlcmdの使い方を書いてみた。

sqlcmdでデータベースの作成

SQLEXPRESSは、インストールと同時にサービスに登録されて自動的に実行されている。念のため、タスクマネージャで確認する。

コマンドプロンプトを開き、sqlcmdでSQLEXPRESSにログインする。sqlcmdは、SQLEXPRESSと同時にインストールされ、パスも勝手に通っている。
今回はWindows認証なので、サーバー名を指定するだけ。先ほどメモ帳に貼り付けた、サーバー名を-Sオプションの後に入力する。

cmd

> sqlcmd -S localhost\SQLEXPRESS

または、localhostを省略して、

> sqlcmd -S .\SQLEXPRESS 

以下のように1>が現れたらログイン成功。

cmd

> sqlcmd -S .\SQLEXPRESS
1>

データベースを新規作成するためのSQL文を以下のようにタイプ後、Enterキーで改行、GOと打ってもう一度Enterすることで、SQL文がSQLEXPRESSに送信される。以下を実行するとHogeDbという名前のデータベースが作られる。

cmd

1> CREATE DATABASE HogeDb
2> GO

GOする前にタイプミスに気づいたときは、RESETと打ってEnterすると、入力をリセットできる。リセットすると行番号が1>に戻るので、最初から入力し直す。

cmd

1> CREATE DATEBACE HogeDb
2> RESET
1>

sqlcmdで、テーブルの作成

次に、でき上がったデータベースの中に、テーブルを作る。まずは使用するデータベースを指定する。

cmd

1> USE HogeDb
2> GO
データベース コンテキストが 'HogeDb' に変更されました。
1>

以下はテーブル作成のSQL文。これを直に入力しても良いが、以下をコピーして、sqlcmdのコマンドラインに貼り付けても良い。

テーブル作成のSQL文

CREATE TABLE 映画(
Id int IDENTITY(1,1) NOT NULL,
題名 nvarchar(MAX) NULL,
製作 int NULL,
上映時間 time NULL,
興行収入 float NULL,
CONSTRAINT PK_映画_Id PRIMARY KEY CLUSTERED(Id)
)

そして最後に、GOを忘れずに打ってSQL文を送信する。。

テーブルができているかどうかは以下のSQLで確認できる。

テーブル一覧

SELECT * FROM sys.objects WHERE TYPE = 'U'

これでデータベースの準備は整った。
sqlcmdを終了させるには、EXITと打つ。

DSNファイルの作成

データベースが作成できたら、データベースとODBC接続するためのDSNファイルを作成する。接続文字列はVBAに直接書き込むのが一般的だが、後々書き換えが必要になったときなどに便利なので、これで接続する方法を書いてみた。

DSNファイルの作成

DSNファイルを保存するフォルダを予め、Cドライブ直下に作成しておく。フォルダパスは C:\odbcdsn とした。作ったフォルダのアイコンで右クリックして「プロパティ」をクリック、「共有」タブを開いてフォルダを共有しておく。

「共有」をクリック。

「共有」をクリック。

「終了」をクリック。

次に、スタートボタンをクリックして「ODBC」と入力すると ODBC Data Sources (32-bit) が現れるので、クリックする。
「ファイルDSN」タブを開いて「追加」をクリック。

リストボックスの中からSQL Serverを探して選択、「次へ」をクリック。

先ほど作成した C:\odbcdsn フォルダのパスを入力して、「次へ」をクリック。

「完了」をクリック。

サーバー名を入力して、「次へ」をクリック。（ここの「完了」は、まだクリックしない）

Windows認証かSQL Server認証かの選択。Windows認証のまま、何もせず「次へ」をクリック。

「既定のデータベースを以下のものに変更する」をチェックして、コンボボックスからHogeDbを選択して、「次へ」をクリック。

「SQL Serverのシステムメッセージを以下の言語に変更する」をチェックして、「完了」をクリック。

「データソースのテスト」をクリック。

テストが無事に完了したことを確認したら、「OK」をクリック。

元のダイアログに戻ったら「OK」をクリックしてダイアログを閉じる。

C:\odbcdsn フォルダを開くと、HogeDb.dsn ファイルができている。

これをメモ帳で開くと、単なるテキストファイルである。

HogeDb.dsn

[ODBC]
DRIVER=SQL Server
UID=nekohei
LANGUAGE=日本語
DATABASE=HogeDb
WSID=AhoNoLavie
APP=MicrosoftR WindowsR Operating System
Trusted_Connection=Yes
SERVER=.\SQLEXPRESS

スタートボタンでの検索時に気付いたと思うが、ODBC Data Sources には 32bit と 64bit がある。違いは何か？自分の環境では、32bit は文字コードがANSI、64bit はUTF-8だった。書かれている内容については一緒である。単なるテキストファイルなので、一々ウィザードなど使わずに、メモ帳からテキストファイルを新規作成してベタ打ちしても問題ない。因みにWindows認証なら、UID行の記載がなくても問題無く接続できる。ドライバーの実態は sqlsrv32.dll、手持ちのExcelは32bit版だったので、32bit を選択した。実際のところ、64bit のUTF-8版で接続を試したらエラーとなった。各自の環境で試してみるといい。

VBAでADOを使うための準備

前置きが長くなったが、ここからが本番。VBEを開き、メニューから[ツール]の[参照設定]を開く。そして、『Microsoft ActiveX Data Objects 2.8 Library』にチェックを入れる。

ここでは2.8を選択したが、バージョンは各自の環境に合わせて選択する。32bit版のOfficeなら、これがいいと思う。
CreateObject関数とObject型変数を使えば参照設定は不要で、バージョンを気にする必要もないが、IntelliSenseが効かないので、コードを書く段階では参照設定しておいた方が書きやすい。

ADOを簡単に使うプロシージャ群

ADOを簡単に使うためのプロシージャ群を書いてみた。これらを一つのModuleシートにまとめておけば、別のブックでも使いまわせる。

ModuleDbTools.bas

' グローバルのConnection、閉じ忘れに注意
Public cn As New ADODB.Connection
' dsnファイルの共有パス
Public Const cnString As String = "FILEDSN=\\127.0.0.1\odbcdsn\HogeDb.dsn;"

' コネクションを確立する
Public Sub CnOpen(Optional cnn As ADODB.Connection)
    On Error GoTo Catch
    If cnn Is Nothing Then Set cnn = cn
    If cnn Is Nothing Then
        cnn.ConnectionString = cnString
    ElseIf cnn.ConnectionString = "" Then
        cnn.ConnectionString = cnString
    End If
    If cnn.State <> adStateOpen Then cnn.Open
    Exit Sub
Catch:
    OutputError "ModuleDbTools.CnOpen"
End Sub

' コネクションを閉じる
Public Sub CnClose(Optional cnn As ADODB.Connection)
    On Error GoTo Catch
    If cnn Is Nothing Then Set cnn = cn
    If cnn.State <> adStateClosed Then cnn.Close
    Exit Sub
Catch:
    OutputError "ModuleDbTools.CnClose"
    Set cnn = Nothing
End Sub

' レコードセットを取得する
Public Function GetRs(sql As String, Optional cursorType As CursorTypeEnum = adOpenKeyset, Optional lockType As LockTypeEnum = adLockOptimistic) As ADODB.Recordset
    On Error GoTo Catch
    Dim rs As New ADODB.Recordset
    CnOpen
    rs.CursorLocation = adUseClient
    rs.Open sql, cn, cursorType, lockType
    Set GetRs = rs
Finally:
    Set rs = Nothing 
    Exit Function
Catch:
    OutputError "ModuleDbTools.GetRs", sql
    GoTo Finally
End Function

' 1レコード目の1列目だけを取得する
Public Function ExecuteScalar(ByVal sql As String) As Variant
    On Error GoTo Catch
    Dim cmd As New ADODB.Command
    Dim rs As ADODB.Recordset
    CnOpen
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = sql
    Set rs = cmd.Execute()
    If rs.EOF Then
        ExecuteScalar = Empty
    Else
        ExecuteScalar = xNz(rs.Fields(0).Value)
    End If
Finally:
    Call RsClose(rs)
    Set cmd = Nothing
    Exit Function
Catch:
    OutputError "ModuleDbTools.ExecuteScalar", sql
    ExecuteScalar = Empty
    GoTo Finally
End Function

' SQLを実行する（レコードセットなし）
Public Function ExecuteNonQuery(sql As String) As Long
    Dim cnt As Long
    Dim cmd As New ADODB.Command
    On Error GoTo Catch
    cnt = -1
    CnOpen
    cmd.ActiveConnection = cn
    cmd.CommandType = adCmdText
    cmd.CommandText = sql
    cmd.Execute cnt
    ExecuteNonQuery = cnt
Finally:
    Set cmd = Nothing
    Exit Function
Catch:
    OutputError "ModuleDbTools.ExecuteNonQuery", sql
    GoTo Finally
End Function

' 指定したシートにデータを呼び出す
Public Function GetData(sh As Worksheet, sql As String, _
                        Optional withTitle As Boolean = False, _
                        Optional specifyRow As Long = 1, _
                        Optional insertRange As Boolean = False) As Long
    On Error GoTo Catch
    Dim rs As ADODB.Recordset: Set rs = GetRs(sql)
    If rs.EOF Then GoTo Finally
    If sh.FilterMode Then sh.ShowAllData
    Dim rwCnt As Long: rwCnt = rs.RecordCount
    If withTitle Then rwCnt = rwCnt + 1
    Dim cmCnt As Long: cmCnt = rs.Fields.Count
    Dim lst() As Variant: ReDim lst(rwCnt - 1, cmCnt - 1) As Variant
    Dim cm As Long, rwBgn As Long
    If withTitle Then
        For cm = 0 To cmCnt - 1
            lst(0, cm) = rs.Fields(cm).Name
        Next
        rwBgn = 1
    End If
    Dim rw As Long
    For rw = rwBgn To rwCnt - 1
        For cm = 0 To cmCnt - 1
            If IsNull(rs.Fields(cm).Value) Then
                lst(rw, cm) = Empty
            ElseIf rs.Fields(cm).Type = adBoolean Then
                If rs.Fields(cm).Value Then
                    lst(rw, cm) = 1
                Else
                    lst(rw, cm) = Empty
                End If
            Else
                lst(rw, cm) = rs.Fields(cm).Value
            End If
        Next
        rs.MoveNext
    Next
    If insertRange Then
        If Application.CutCopyMode Then Application.CutCopyMode = False
        sh.Range("A" & specifyRow).Resize(rwCnt).EntireRow.Insert , xlFormatFromRightOrBelow
    End If
    sh.Range("A" & specifyRow, sh.Cells(rwCnt + specifyRow - 1, cmCnt)).Value = lst
    GoTo Finally
Catch:
    Select Case Err.Number
    Case 13
        Err.Clear
    Case Else
        MsgBox Err.Description, vbExclamation
        rw = 0
    End Select
    OutputError "ModuleDbTools.GetData", sql
Finally:
    RsClose rs
    GetData = rw
End Function

' AccessのNz関数のようなもの
Public Function xNz(X As Variant, Optional 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 "ModuleDbTools.xNz"
End Function

' レコードセットを閉じる定型文をプロシージャ化
Public Sub RsClose(rs As ADODB.Recordset)
    If Not rs Is Nothing Then
        If rs.State <> ObjectStateEnum.adStateClosed Then rs.Close
    End If
End Sub

' エラーメッセージ出力
Public Sub OutputError(errPlace As String, Optional errNote As String)
    Dim msg As String
    msg = vbCrLf
    msg = "日時：" & Format$(Now(), "yyyy/mm/dd hh:nn:ss") & vbCrLf
    msg = msg & "ソース：" & Err.Source & vbCrLf
    msg = msg & "ブック名：" & ActiveWorkbook.Name & vbCrLf
    msg = msg & "場所：" & errPlace & vbCrLf
    msg = msg & "備考：" & errNote & vbCrLf
    msg = msg & "エラー番号：" & Err.Number & vbCrLf
    msg = msg & "エラー内容：" & Err.Description & vbCrLf
    Debug.Print msg
End Sub

ADOでデータを登録する

データを登録する方法はいくつか考えられるが、ここでは単純にSQLを投げてみる。
前節のExecuteNonQueryプロシージャの引数にSQL文を渡すだけだ。

データを登録する

Sub Hoge1()

    Dim sql As String
    sql = "INSERT INTO 映画 (題名,製作,上映時間,興行収入) VALUES "
    sql = sql & "('続夕陽のガンマン',1966,'2:59:00',25100000),"
    sql = sql & "('カッコーの巣の上で',1975,'2:13:00',108981275),"
    sql = sql & "('天国から来たチャンピオン',1978,'1:41:00',81640278),"
    sql = sql & "('ブレードランナー',1982,'1:56:00',32868943)"
    
    Dim cnt As Long
    cnt = ExecuteNonQuery(sql)
    ' 4件のデータを登録したのでcntには4が代入される
    Debug.Print cnt & "件追加"
    
    Call CnClose

End Sub

ExecuteNonQueryプロシージャ内でCnOpenプロシージャを実行して、SQL Serverとの接続を確立した上でSQL文を投げている。

ワークシートにデータを呼び出す

次に、登録したデータをワークシートのSheet1に呼び出してみる。

データを呼び出す

Sub Hoge2()

    Dim sql As String
    sql = "SELECT * FROM 映画"
    
    Dim cnt As Long
    cnt = GetData(Sheet1, sql, True)
    
    Call CnClose

End Sub

GetDataプロシージャではGetRsプロシージャを使ってレコードセットを取得し、それを2次元配列に格納して引数で指定したSheet1のセルA1を始点にデータを吐き出している。3つ目の引数をTrueにすることで出力に列名が付加される。

以下が出力結果である。（※D列とE列は書式設定しています）

データベースを書き換える

これにもいくつか方法がある。前出のExecuteNonQueryプロシージャにUPDATE文を渡す方法もあるが、ここではRecordsetを使ってやってみる。

データを更新する

Sub Hoge3()
    
    Dim sql As String
    sql = "SELECT 題名,上映時間 FROM 映画"
    
    Dim rs As ADODB.Recordset
    Set rs = GetRs(sql)
    
    Do Until rs.EOF
        If xNz(rs.Fields("題名").Value) = "ブレードランナー" Then
            rs.Fields("上映時間").Value = "1:57:00"
            rs.Update
        End If
        rs.MoveNext
    Loop

    Call RsClose(rs)
    Call CnClose
    
End Sub

実際にこのように単純な更新なら、ループなど使わずにピンポイントでデータ更新するだろうが、ここでは使用例を示すのが目的なのでこう書いた。

おわりに

そこそこVBAを書けるが、データベースにはまだ踏み込んでいない方なら、ADOは非常にお勧めだ。今回紹介したADOツールはこのまま使っても良し、自分なりに書き換えても良し、以後はそれを使って簡単にVBAが書ける。VBAロジックを更に簡単に書くには、どれだけ複雑なSQL文が書けるかだということに気づき始めると自然とSQLを探究したくなる。

VBAでのADOの利用は、SQLと戯れたくなる大きな動機付けになるのだ