VBAからsqlite3.exeを呼び出してdllやODBCを使用せずにsqlite3を利用する

VBAからsqlite3.exeを呼び出してdllやODBCを使用せずにsqlite3を利用する

バッチファイルを実行し、結果ファイルをHTMLのTableタグで出力し、出力した結果を開いてRecodesetへ取り込む。

-------------------------------------------------

Private Const SQLITE_EXE As String = "sqlite3.exe"
Private Const RESULT_FILENAME As String = "Result.xml"
Private Const EXEC_SQL As String = "ExecSQL.sql"
Private Const EXEC_BATCH As String = "ExecBatch.bat"
Private Const DB_PATH As String = "C:\Users\UserName\Desktop\PgUserName\DataBase\開発PJ.prj"
Private Const FOLDER_PATH As String = "C:\Users\UserName\Desktop\PgUserName\"
Private Const CHARSET_UTF8 As String = "UTF-8"
Private Const CHARSET_SJIS As String = "Shift-JIS"
'参照設定：Microsoft ActiveX Data Object Library 2.8
Private Function GetData(ByVal strSql As String, ByRef rdSet As ADODB.Recordset)
 
    'SQLを実行する
    Call ExecuteSqlite3(strSql)
    '出力結果のファイルを取得し、RecordSetに取り込む
    Dim strResultFilePath As String
    strResultFilePath = ThisWorkbook.Path & "\temp\" & RESULT_FILENAME
    Dim buf As String, Target As String, lngRow As Long, lngItem As Long
    Dim blnIsHeader As Boolean
    Dim strRows As Variant, strItems As Variant, j As Long
    Dim strSplitName As String
    
    blnIsHeader = True
    
    Dim rdResult As ADODB.Recordset
    Set rdResult = New ADODB.Recordset
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile strResultFilePath
        buf = .ReadText
        .Close
        '<TR>～</TR>で1行
        
        
        buf = Replace(buf, "<TR>", "")
        strRows = Split(buf, "</TR>" & vbLf)
        For lngRow = 0 To UBound(strRows)
            If blnIsHeader = True Then
                strSplitName = "</TH>"
            Else
                strSplitName = "</TD>"
                '行を追加
                rdResult.AddNew
            End If
            
            strItems = Split(strRows(lngRow), strSplitName & vbLf)
            
            Dim strtemp As String
            strtemp = ""
            For lngItem = 0 To UBound(strItems) - 1  '空白行が最後に含まれる
                strtemp = Mid(strItems(lngItem), 5)
                
                If blnIsHeader = True Then
                    rdResult.Fields.Append strtemp, adLongVarWChar, 255, adFldIsNullable
                Else
                    rdResult.Fields(lngItem) = strtemp
                End If
                
            Next
            
            If blnIsHeader = True Then
                blnIsHeader = False
                rdResult.Open
            Else
                rdResult.Update
            End If
        Next
        
    End With
    Set rdSet = rdResult
End Function

Private Sub ExecuteSqlite3(ByVal strSql As String)
    Dim strCommand As String
    Dim strSqlCommand As String
    
    Dim strTempFolderPath As String
    strTempFolderPath = ThisWorkbook.Path & "\temp"
    If Dir(strTempFolderPath, vbDirectory) = "" Then
        MkDir strTempFolderPath
    End If
    
    Dim strSqlite3ExePath As String
    strSqlite3ExePath = ThisWorkbook.Path & "\" & SQLITE_EXE
    
    Dim strResultFilePath As String
    strResultFilePath = "./" & RESULT_FILENAME
    
    Dim strBatchFilePath As String
    strBatchFilePath = strTempFolderPath & "\" & EXEC_BATCH
    
    Dim strExecSqlPath As String
    strExecSqlPath = strTempFolderPath & "\" & EXEC_SQL
    'sqlite3を実行するときのオプションコマンド
    strSqlCommand = ".headers on " & vbCrLf
    strSqlCommand = strSqlCommand & ".mode html " & vbCrLf
    strSqlCommand = strSqlCommand & ".output '" & Replace(strResultFilePath, "\", "/") & "'" & vbCrLf
    
    strSqlCommand = strSqlCommand & strSql & vbCrLf
    
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strSqlCommand, strExecSqlPath, CHARSET_UTF8, True)
    'バッチ用コマンド
    strCommand = ""
    strCommand = strCommand & strSqlite3ExePath & " " & DB_PATH & " < " & strExecSqlPath
    'sqlite3に渡すコマンドを出力する
    Call TextOutput(strCommand, strBatchFilePath, CHARSET_SJIS)
    Dim wsh As Object
    Dim result As Integer
    
    Set wsh = CreateObject("WScript.Shell")
    
    'バッチファイルを同期実行
    result = wsh.Run(Command:=strBatchFilePath, WaitOnReturn:=True)
    If (result = 0) Then
        Debug.Print ("バッチファイルは正常終了しました。")
    Else
        Debug.Print ("バッチファイルは異常終了しました。")
    End If
    
    '後片付け
    Set wsh = Nothing
    
End Sub
Public Sub TextOutput(ByVal strText As String, ByVal strFilePath As String, ByVal strCharSet As String, Optional ByVal blnNoBOM As Boolean = False)
    Dim i As Integer
     
    'ADODB.Streamオブジェクトを生成
    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
     
    'ADODB.Streamで扱う文字コードを設定する
    ado.Charset = strCharSet
     
    'ADODB.Streamを開く
    ado.Open
     
    '開いたADODB.Streamに内容を保管する
    'adWriteLineは改行する時に入れる
     ado.WriteText strText
        ' ---------- ここから ----------
    If blnNoBOM = True And strCharSet = CHARSET_UTF8 Then
    
        With ado
            ' タイプをバイナリにして、先頭の3バイトをスキップ
            .Position = 0
            .Type = 1 ' ADODB.StreamTypeEnum.adTypeBinary ' タイプ変更するにはPosition = 0である必要がある
            .Position = 3
            ' 一時格納用
            Dim p_byteData() As Byte
            p_byteData = .Read
            .Close ' 一旦閉じて
            .Open ' 再度開いて
            .Write p_byteData ' ストリームに書き込む
        End With
    
    End If
     
    'ADODB.Streamに保管されている内容をファイルに保存する
    ado.SaveToFile strFilePath, 2
     
    'ADODB.Streamを閉じる
    ado.Close
   
End Sub