ACCESSからプリペアドステートメントを実行する

はじめに

Accessでプリペアドステートメント実行してみたいと思いました。
色々調べてたら一応それらしいものはあるってことだったので、試したところ、どうしても文字コードでエラーが・・・。
どうやらDNSMySQL ODBC 5.3 Unicode Driverの指定が間違っていたようで、MySQL ODBC 5.3 ANSI Driverに変更したところ正常にパスしたため公開。
なお、環境なんかはこちらに詳しく記載しています。

クラスモジュール

MySql.cls

Option Compare Database
Option Explicit
' **
' * モジュール名     ： MySql
' *
' * メソッド
' * connect            : MySQLとのコネクションを確立する
' * prepare            : Prepared Statementを発行する
' * setParameterHash   : Prepared Statement用のパラメータをコレクションにセットする
' * clearParameterHash : コレクションの中身を空にする（連続処理時に使用）
' * setParameter       : コレクションをPrepared Statementにセットする
' * executeStmt        : SQL文を実行する（INSERT・UPDATE用）
' * fetchStmt          : レコードセットを取得する（SELECT用）
' **

Private ado_connection As Object
Private ado_command    As Object
Private parameter_hash As Object

' **
' * メソッド名 : connect
' * 機能       : MySQLとのコネクションを確立する
' * 引数       : なし
' * 戻り値     : 自分自身（チェーンメソッド）
' **
Public Function connect() As MySql
On Error GoTo Error
    Dim cn      As String
    Dim ado_con As Object

    Set ado_con = CreateObject("ADODB.Connection")

    ' ドライバ他接続用のパラメータ
    cn = "Driver={MySQL ODBC 5.3 ANSI Driver};" & _
         "Server=192.168.10.10;" & _
         "PORT=3306;" & _
         "UID=access;" & _
         "PWD=access;"
    ' DriverにUnicodeを指定した場合、プリペアドステートメント実行時に文字コードエラーが発生する

    ' 接続用のパラメータを利用してデータベースとのコネクションを確立する
    ado_con.Open (cn)
    ' コネクションをオブジェクトにセットする
    Set ado_connection = ado_con
    ' 自分自身を返す
    Set connect = Me
    Exit Function
Error:
    MsgBox Err.Number & vbCrLf & Err.Description
End Function

' **
' * メソッド名： prepare
' * 機能      ： prepared statementを発行する（現時点ではSQL文を実行しない）
' * 引数      ： sql文（パラメータは?で指定する）
' * 戻り値    ： 自分自身（チェーンメソッド）
' **
Public Function prepare(sql As Variant) As MySql
On Error GoTo Error
    Dim cmd As Object
    Set cmd = CreateObject("ADODB.Command")

    ' コマンドのコネクションに予め確立していたコネクションをセット
    cmd.ActiveConnection = ado_connection

    ' プリペアドステートメントを発行
    With cmd
        .CommandText = sql
        .CommandType = adCmdText
        .Prepared    = True
    End With
    Set ado_command  = cmd
    Set prepare      = Me
    Exit Function
Error:
    MsgBox Err.Number & vbCrLf & Err.Description
End Function

' **
' * メソッド名： setParameter
' * 機能      ： 生成したパラメータをSQL文に埋め込む（実行はまだ行わない）
' * 引数      ： なし
' * 戻り値    ： 自分自身（チェーンメソッド）
' **
Public Function setParameter()
On Error GoTo Error
    Dim param As Object
    Dim key   As Variant
    Dim arr   As Object

    Set param = New ADODB.parameter

    If parameter_hash Is Nothing Then
        ' パラメータが存在しない平文の場合、処理をスルー
    Else
        ' パラメータが存在する場合、一つ一つにセットしていく
        For Each key In parameter_hash
            ' arrに1レコードごとのパラメータをセット
            Set arr = parameter_hash.Item(key)

            'パラメータを利用してクエリにセット
            Set param = ado_command.CreateParameter(key, arr.Item("type"), adParamInput, arr.Item("size"))
            ado_command.parameters.Append param
            ado_command.parameters(key) = arr.Item("value")

        Next key
    End If
    Set ado_command  = ado_command
    Set setParameter = Me
    Exit Function
Error:
    MsgBox Err.Number & vbCrLf & Err.Description
End Function

' **
' * メソッド名： executeStmt
' * 機能      ： プリペアドステートメントを実行する（INSERT・UPDATE用）
' * 引数      ： なし
' * 戻り値    ： 自分自身（チェーンメソッド）
' **
Public Function executeStmt()
    ado_command.Execute
End Function

' **
' * メソッド名： fetchStmt
' * 機能      ： プリペアドステートメントを実行する（SELECT用）
' * 引数      ： なし
' * 戻り値    ： レコードセット
' **
Public Function fetchStmt()
    Dim res
    Set res       = New ADODB.Recordset
    Set res       = ado_command.Execute
    Set fetchStmt = res
End Function

' **
' * メソッド名： setParameterHash
' * 機能      ： プリペアドステートメント用のキーと値をコレクションにセットする
' * 引数      ： キー（カラム名）・値・変数型・変数長
' * 戻り値    ： 自分自身（チェーンメソッド）
' * 備考      ： Typeについては https://msdn.microsoft.com/ja-jp/library/cc389790.aspx を参照
' **
Public Function setParameterHash(param_key As String,
                                 param_value As Variant,
                                 param_type As Variant,
                                 param_size As Variant) As MySql
On Error GoTo Error
    If parameter_hash Is Nothing Then
        ' パラメータ用連想配列が存在しなければこの時点で生成
        Set parameter_hash = CreateObject("Scripting.Dictionary")
    End If

    Dim param As Object
    ' parameterを連想配列化
    Set param = CreateObject("Scripting.Dictionary")
    param.Add key:="value", Item:=param_value
    param.Add key:="type",  Item:=param_type
    param.Add key:="size",  Item:=param_size
   'param.Add key:="size",  Item:=Len(param_value) ' テストしてないけど多分これでも通る、こうすると引数1つ減らせる

    ' ハッシュマップに連想配列をセット
    parameter_hash.Add key:=param_key, Item:=param

    Set param            = Nothing
    Set setParameterHash = Me
    Exit Function
Error:
    MsgBox Err.Number & vbCrLf & Err.Description
End Function

' **
' * メソッド名： clearParameterHash
' * 機能      ： コレクションの中身を空にする（連続処理時に使用）
' * 引数      ： なし
' * 戻り値    ： 自分自身（チェーンメソッド）
' **
Public Function clearParameterHash() As MySql
    Set parameter_hash = Nothing
    Set clearParameterHash = Me
End Function

メインフォーム

form_1.cls

' INSERTテスト
Private Sub button_1_Click()
    dim obj as Object
    Set obj = New MySql

    sql = "INSERT INTO access_db.sample_tables (id, message, modified_at) VALUES (null, ?, ?);"
    obj. _
        connect(). _
        prepare(sql). _
        setParameterHash("message",     "テストメッセージです。", adChar,        100). _
        setParameterHash("modified_at", Now(),                  adDBTimeStamp, 16). _
        setParameter(). _
        executeStmt

    MsgBox "INSERTが終了しました。"
End Sub

' UPDATEテスト
Private Sub button_2_Click()
    dim obj as Object
    Set obj = New MySql

    sql = "UPDATE access_db.sample_tables SET message=?, modified_at=? WHERE id=?;"
    obj. _
        connect(). _
        prepare(sql). _
        setParameterHash("message",     "編集しました。", adChar,        100). _
        setParameterHash("modified_at", Now(),           adDBTimeStamp, 16). _
        setParameterHash("id",          1,               adInteger,     8). _
        setParameter(). _
        executeStmt

    MsgBox "UPDATEが終了しました。"
End Sub

' DELETEテスト
Private Sub button_3_Click()
    dim obj as Object
    Set obj = New MySql

    sql = "DELETE FROM access_db.sample_tables WHERE id=?;"
    obj. _
        connect(). _
        prepare(sql). _
        setParameterHash("id", 1, adInteger, 8). _
        setParameter(). _
        executeStmt

    MsgBox "DELETEが終了しました。"
End Sub

' SELECTテスト － パラメータなし
Private Sub button_4_Click()
    dim obj as Object
    Set obj = New MySql

    sql = "SELECT * FROM access_db.sample_tables;"
    Set rs = obj. _
        connect(). _
        prepare(sql). _
        fetchStmt
        ' setParameterHash,setParameterなし
        ' execute -> fetchへ

    Do Until rs.EOF
        debug.print "id=" & rs!id & ", message='" & rs!message & "'"
        rs.MoveNext
    Loop
    MsgBox "SELECTが終了しました。"
End Sub

' まとめてINSERTしてみる
Private Sub button_5_Click()
    Set obj = New MySql
    sql = "INSERT INTO access_db.sample_tables (id, message, modified_at) VALUES (null, ?, ?);"

    For i = 1 To 1000
    obj.connect().prepare(sql). _
        clearParameterHash(). _
        setParameterHash("message", "テストメッセージ" & i, adChar, 20). _
        setParameterHash("updated_at", Now(), adDBTimeStamp, 16). _
        setParameter(). _
        executeStmt
    Next
    MsgBox "INSERTが終了しました。"

End Sub

注意事項

• 大量のデータでテストを行ったわけではないので、もしかしたらこういうエラーが出るかもしれません。ステートメント発行するたびにオブジェクト破棄すれば回避できるのかな？でもベストプラクティスではないよねー。
• setParameterHashのTypeについてはこちらをご参照ください。
• setParameterHashのSizeについてはこちらを。省略可能って書いてんのに省略した途端エラー吐くって意味わかんねぇだろ。
• Sizeについて書いてて思ったけど引数のparam_valueのlengthそのままセットでもいいんじゃね？ってことでコメントに記載。一応テストはしてるけど、全部の型をテストしたわけじゃない。

所感

分かればなんてことはないエラーだったのですが、半日近くハマりました。
しばらく文字コードのことは考えたくないです。
とりあえずプリペアドステートメントを実行できるようにはなりましたが、使いみちはあるのやら・・・
あとはトランザクションやらコミットやら・・・う、うん。