hakeの日記

Windows環境でプログラミングの勉強をしています。

EXCEL VBAメモ - SQLite3データベースのアクセス（SQLiteForExcel使用）

excel VBA database SQLite

ExcelからODBCドライバをインストールせずにSQLite3へアクセスする方法

準備(64bit環境の場合)

  • Releases · govert/SQLiteForExcel · GitHub からSQLite For Excelの最新版を入手（現時点ではSQLiteForExcel-1.0.zip）しアーカイブの中から、SQLiteForExcel_64.xlsmをとりだして使用する。32bit環境では同梱されているSQLite3_StdCall.dllを同じ場所に置く必要があるようですが64bit環境では不要の様です。
  • SQLite Home Pageからsqlite3.dllを入手して別途コピーする。（現時点の最新は、sqlite-dll-win64-x64-3260000.zip）

　

動作確認

sqlite3.dllの置き場所に注意

    #If Win64 Then
        ' I put the 64-bit version of SQLite.dll under a subdirectory called x64
        InitReturn = SQLite3Initialize(ThisWorkbook.Path + "\x64")
    #Else

して、SQLiteForExcel_64.xlsmのSqlite3Demoモジュール中の AllTestsプロシージャを実行する。結果はDebug.Printでイミディエイトウィンドウに表示されるのでエラーが無ければOK

問題点

自分の環境（Winows10 1809 / Excel for Office 365(64bit) )ではTestBackupプロシージャの実行でExcelが落ちましたので、この機能は使用しないことにします。
　

SQLite4Excelクラスの作成

ODBC版と似たような使い勝手にするためにクラス化してみる（32bit版では、LongPtr型をLongに変更する）
SQLiteForExcel_64.xlsmのSqliteモジュールのあるブックに以下のクラスモジュールを作成する。

Option Explicit
'SQLite4Excel.cls

Dim mDbh As LongPtr
Dim mSth As LongPtr
Dim mFile As String
Dim mSQL As String
Dim mRecords As Variant
Dim mIdx As Long

Private Sub Class_Initialize()
    Dim ret As Long
    ret = SQLite3Initialize(ThisWorkbook.Path)
    If ret <> SQLITE_INIT_OK Then
        Err.Raise 999, "Error Initializing SQLite. Error: " & Err.LastDllError
    End If
End Sub

Private Sub Class_Terminate()
    Dim ret As Long
    ret = SQLite3Close(mDbh)
    If ret <> SQLITE_OK Then
        Err.Raise 999, "DB File Close" & vbCrLf & _
        "Error: " & SQLite3ErrMsg(mDbh)
    End If
End Sub

'レコードセット読み取り
Property Get RS() As Variant
    RS = mRecords(mIdx)
End Property

'レコード数
Property Get RecordCount() As Long
    RecordCount = UBound(mRecords) - LBound(mRecords) + 1
End Property

'レコード終端か否か
Property Get EOF() As Boolean
    If mIdx = Me.RecordCount Then
        EOF = True
    Else
        EOF = False
    End If
End Property

'次のレコード
Public Function MoveNext()
    mIdx = mIdx + 1
End Function

'最初のレコード
Public Function MoveFirst()
    mIdx = 0
End Function

'初期化
Public Sub Prepare(ByVal file As String)
    Dim ret As Long
    mFile = file
    ret = SQLite3Open(mFile, mDbh)
    If ret <> SQLITE_OK Then
        Err.Raise 999, "DB File Open" & vbCrLf & _
        "Error: " & SQLite3ErrMsg(mDbh)
    End If
End Sub

'通常SQL発行
Public Sub Execute(ByVal sql As String)
    Dim ret As String
    ret = SQLite3PrepareV2(mDbh, sql, mSth)
    If ret <> SQLITE_OK Then
        Err.Raise 999, _
            "SQLite3DB.Eecute" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3PrepareV2" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
    ret = SQLite3Step(mSth)
    If ret <> SQLITE_DONE Then
        Err.Raise 999, _
            "SQLite3DB.Eecute" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3Step" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
    ret = SQLite3Finalize(mSth)
    If ret <> SQLITE_OK Then
        Err.Raise 999, _
            "SQLite3DB.Eecute" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3Finallize" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
End Sub

'SELECT文を発行し、レコード値をmRecordsに格納
' mRecordsの型は、Array( Array( ), ……)
Public Sub Query(ByVal sql As String)
    Dim ret As Long
    Dim i As Long
    Dim rc As Variant
    Dim cnt As Long
    Dim colType As Long
    Dim colValue As Variant
    
    mRecords = Array()
    mIdx = 0
    
    ret = SQLite3PrepareV2(mDbh, sql, mSth)
    If ret <> SQLITE_OK Then
        Err.Raise 999, _
            "SQLite3DB.Query" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3PrepareV2" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
    ret = SQLite3Step(mSth)
    Do While ret = SQLITE_ROW
        rc = Array()
        cnt = SQLite3ColumnCount(mSth)
        For i = 0 To cnt - 1
            'colName = SQLite3ColumnName(sth, i)
            colType = SQLite3ColumnType(mSth, i)
            colValue = ColumnValue(mSth, i, colType)
            ReDim Preserve rc(UBound(rc) + 1)
            rc(UBound(rc)) = colValue
        Next
        ReDim Preserve mRecords(UBound(mRecords) + 1)
        mRecords(UBound(mRecords)) = rc
                
        ret = SQLite3Step(mSth)
    Loop
    If ret <> SQLITE_DONE Then
        Err.Raise 999, _
            "SQLite3DB.Query" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3Step" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
    ret = SQLite3Finalize(mSth)
    If ret <> SQLITE_OK Then
        Err.Raise 999, _
            "SQLite3DB.Query" & vbCrLf & _
            "SQL: " & sql & vbCrLf & _
            "SQLite3Finallize" & vbCrLf & _
            "Error: " & SQLite3ErrMsg(mDbh)
    End If
End Sub

' 以下はSqlite3Demoモジュールから借用
Private Function ColumnValue(ByVal stmtHandle As LongPtr, ByVal ZeroBasedColIndex As Long, ByVal SQLiteType As Long) As Variant
    Select Case SQLiteType
        Case SQLITE_INTEGER:
            ColumnValue = SQLite3ColumnInt32(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_FLOAT:
            ColumnValue = SQLite3ColumnDouble(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_TEXT:
            ColumnValue = SQLite3ColumnText(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_BLOB:
            ColumnValue = SQLite3ColumnText(stmtHandle, ZeroBasedColIndex)
        Case SQLITE_NULL:
            ColumnValue = Null
    End Select
End Function

　

作成したクラスの使用例

発行するSQLの最後にセミコロンをつけないこと。

Sub test()
    On Error GoTo Err_handler
    Dim file As String
    Dim db As SQLite4Excel
    Dim i As Long
    
    file = ThisWorkbook.Path & "\" & "testSQ3ForExcel.db"
    Set db = New SQLite4Excel
    
    db.Prepare file
    db.Execute "CREATE TABLE IF NOT EXISTS aaa(tt TEXT,ii INTEGER)"
    
    db.Execute "BEGIN TRANSACTION"
    For i = 1 To 10000
        db.Execute "INSERT INTO aaa VALUES('abc" & i & "', " & i & ")"
    Next
    db.Execute "COMMIT TRANSACTION"
    db.Execute "UPDATE aaa SET tt='zzz' WHERE ii=9995"
    db.Execute "DELETE FROM aaa WHERE ii = 9996"
    db.Execute "UPDATE aaa SET tt=NULL WHERE ii=10000"
    

    Dim r As Range
    Set r = Range("A1")
    
    db.Query "SELECT COUNT(*) FROM aaa"
    r.Value = db.RS(0)
    Set r = r.offset(1)
    
    db.Query "SELECT * FROM aaa WHERE ii>9990"
    If db.EOF Then
        MsgBox "MSG : RecordSet Empty"
    Else
        Do Until db.EOF = True
            r.Value = db.RS(0)
            r.offset(0, 1).Value = db.RS(1)
            Set r = r.offset(1)
            db.MoveNext
        Loop
    End If

    GoTo Finally

Err_handler:
    MsgBox Err.Number & vbCrLf & _
        Err.Description & vbCrLf & _
        Err.Source

Finally:
    Set db = Nothing
End Sub