VB Access VBA如何使用Sqlite3数据库

VB Access VBA如何使用Sqlite3数据库

转自：谢厂节的博客

一、先建立一个类模块 

VERSION 1.0 CLASS

BEGIN

  MultiUse = -1  'True

  Persistable = 0  'NotPersistable

  DataBindingBehavior = 0  'vbNone

  DataSourceBehavior  = 0  'vbNone

  MTSTransactionMode  = 0  'NotAnMTSObject

END

Attribute VB_Name = "cCDECL"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = True

Attribute VB_PredeclaredId = False

Attribute VB_Exposed = False

'--------------------------------------------------------------------------

'

' cCDECL - Class that enables the user to call cdecl dynamic link libraries.

'          Supports cdecl style variable argument lists and bas module

'          callbacks.

'

'031029 First cut....................................................... v1.00

'071129 Uses virtual memory rather than string space to fix a DEP issue. v1.01

'

Option Explicit

Option Base 0

'API declarations

Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long

Private Declare Function GetLastError Lib "kernel32" () As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long

Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long

Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long

Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long)

Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Byte)

Private Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer)

Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)

Private Declare Sub PutMem8 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Currency)

Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)

'Private constants

Private Const ERR_SRC       As String = "cCDECL"    'Error source name

Private Const ERR_NUM       As Long = vbObjectError 'cCDECL error number base

Private Const MAX_ARG       As Long = 16            'Maximum number of parameters, you can change this if required

Private Const PATCH_01      As Long = 15            'CDECL patch, CDECL function address

Private Const PATCH_02      As Long = 10            'Callback patch, bas mod function address patch

Private Const PATCH_03      As Long = 16            'Callback patch, stack adjustment patch

'Parameter block

Private Type tParamBlock

  ParamCount                As Long                 'Number of parameters to be forwarded to the cdecl function

  Params(0 To MAX_ARG - 1)  As Long                 'Array of parameters to be forwarded to the cdecl function

End Type

'Private member

Private m_LastError         As Long                 'Last error private member

'Private variables

Private bNewDLL             As Boolean              'Flag to indicate that the loaded DLL has changed

Private hMod                As Long                 'DLL module handle

Private nAddr               As Long                 'Cache the previous cdecl function's address

Private pCode               As Long                 'Pointer to the CDECL code

Private sLastFunc           As String               'Cache the previous cdecl function's name

Private pb                  As tParamBlock          'Parameter block instance

'Replace the stub proc (z_DO_NOT_CALL) with machine-code to handle the cdecl function

Private Sub Class_Initialize()

    Dim pMe As Long

    'Get the address of my vtable into pMe

    GetMem4 ObjPtr(Me), pMe

    'Allocate a page of executable memory

    pCode = VirtualAlloc(0, &H1000&, &H1000&, &H40&)

    'Copy the CDECL translation code to memory

    PutMem8 pCode + 0, -208642111809017.9757@

    PutMem8 pCode + 8, -605931634821031.5515@

    PutMem8 pCode + 16, 20765931315670.1386@

    PutMem8 pCode + 24, -857143604525899.4687@

    PutMem4 pCode + 32, &HC2C03102

    PutMem2 pCode + 36, &HC

    'Patch the first vtable entry (z_DO_NOT_CALL) to point to the CDECL code

    PutMem4 pMe + &H1C, pCode

    'Copy the callback thunk code to memory

    PutMem8 pCode + 40, 479615108421936.7656@

    PutMem8 pCode + 48, -140483859888551.3191@

    PutMem8 pCode + 56, 99649511.6971@

    PutMem8 pCode + 64, 21442817159.0144@

End Sub

Private Sub Class_Terminate()

    'Free virtual memory

    VirtualFree pCode, 0, &H8000&

End Sub

'This sub is replaced by machine code at pCode at class instance creation...

'IT MUST ONLY be called internally by CallFunc.

Public Function z_DO_NOT_CALL(ByVal nAddrParamBlock As Long) As Long

End Function

'Purpose:

' Call the named cdecl function with the passed parameters

'

'Arguments:

' sFunction - Name of the cdecl function to call

' ParmLongs - ParamArray of parameters to pass to the named cdecl function

'

'Return:

'  The return value of the named cdecl function

Public Function CallFunc(ByVal sFunction As String, ParamArray ParmLongs() As Variant) As Long

    Dim i As Long

    Dim j As Long

    'Check that the DLL is loaded

    If hMod = 0 Then

        'If in the IDE just stop, programmer may have On Error Resume Next protection and miss the problem.

        Debug.Assert False

        Call Err.Raise(ERR_NUM + 0, ERR_SRC, "DLL not loaded")

    End If

    'Check to see if we're calling the same cdecl function as the previous call to CallFunc

    If (StrComp(sLastFunc, sFunction) <> 0) Or bNewDLL Then

        'Get the address of the function

        nAddr = GetProcAddress(hMod, sFunction)

        If nAddr = 0 Then

            'If in the IDE just stop, programmer may have On Error Resume Next protection and miss the problem.

            Debug.Assert False

            Call Err.Raise(ERR_NUM + 1, ERR_SRC, "Failed to locate function: " & sFunction)

        End If

        'Patch the code buffer to call the relative address to the cdecl function

        PutMem4 pCode + PATCH_01, nAddr - pCode - (PATCH_01 + 4)

        bNewDLL = False

        sLastFunc = sFunction

    End If

    With pb

        j = UBound(ParmLongs)

        If j >= MAX_ARG Then

            'If in the IDE just stop, programmer may have On Error Resume Next protection and miss the problem.

            Debug.Assert False

            Call Err.Raise(ERR_NUM + 2, ERR_SRC, "Too many parameters")

        End If

        'Fill the parameter block

        For i = 0 To j

            .Params(i) = ParmLongs(i)

        Next i

        .ParamCount = i                                         '(j + 1)

    End With

    Call SetLastError(0)                                      'Clear the error code

    CallFunc = z_DO_NOT_CALL(VarPtr(pb))                      'Execute the code buffer passing the address of the parameter block

    m_LastError = GetLastError()                              'Get error code

End Function

'Load the DLL

Public Function DllLoad(ByVal sName As String) As Boolean

    hMod = LoadLibraryA(sName)

    If hMod <> 0 Then

        DllLoad = True

        'It's remotely possible that the programmer could change the dll and then call a function

        'in the new dll with exactly the same name as the previous CallFunc to the previous DLL. This would

        'defeat the caching scheme and result in the old function in the old dll being called. An unlikely

        'scenario, but stranger things have happened. Soooo, explicitly indicate that we're using a new dll

        bNewDLL = True

    End If

    'If in the IDE just stop on failure, programmer may not be checking the return value.

    Debug.Assert DllLoad

End Function

'It's not important to do this, but, if you've finished with a DLL there's no harm in releasing

'its memory. Don't bother at app end... it will be dealt with automatically when the process ends.

Public Function DllUnload() As Boolean

    If hMod <> 0 Then

        DllUnload = (FreeLibrary(hMod) <> 0)

        hMod = 0

    End If

    'If in the IDE, get the programmer's attention

    Debug.Assert DllUnload

End Function

'Return the cdecl function's error code

Public Property Get LastError() As Long

    LastError = m_LastError

End Property

'Purpose:

' Setup a wrapper so that a bas module function can act as a cdecl callback

'

'Arguments:

' nModFuncAddr - The address of the bas module function to act as a cdecl callback (use AddressOf)

' nParms       - The number of parameters that will be passed to the bas module function

'

'Return:

'  The address to pass to the cdecl function as the callback address

'

Public Function WrapCallback(ByVal nModFuncAddr As Long, ByVal nParms As Long) As Long

    Dim nStackAdjust As Long                                  'The number of bytes to adjust the stack

    WrapCallback = pCode + 40                                 'Address of the callback wrapper

    nStackAdjust = nParms * 4                                 'Four bytes per parameter

    'Patch the code buffer to call the vb bas module callback function

    PutMem4 WrapCallback + PATCH_02, nModFuncAddr - WrapCallback - (PATCH_02 + 4)

    'Patch the code buffer to apply the necessary stack adjustment

    PutMem4 WrapCallback + PATCH_03, nStackAdjust

End Function

国内现在用VB好像很少了，一个项目用到Sqlite3，发现相关资料比较凌乱，也有很多不同使用方法。需要注意的是，Vb调用Sqlite3可使用上面的类模块，官方网站下载的不好用（注册老是失败）。特把使用方法记录在这里。

1.添加附件的类模块 cCDECL.cls

2.添加附件的模块 mDeclarations.bas,mSqlite.bas

Private Sub checkHistory()  

    Dim sPath As String  

    sPath = App.path & "\..\data\"  

    If mSqlite.sqlite3_initialize(sPath) <> SQLITE_OK Then  

        Debug.Print "error"  

        Exit Sub  

    End If  

    If mSqlite.sqlite3_open(sPath & "data.sqlite", f_lSqlite) <> SQLITE_OK Then  

        Debug.Print "error"  

        Exit Sub  

    End If  

    If mSqlite.sqlite3_prepare_v2(f_lSqlite, "SELECT id,flag,send_username,send_cop,send_mail,send_phone,cmbType,cmbW,cmbC,cmbH FROM history WHERE flag=0", 0, f_lStatement, 0) = SQLITE_OK Then  

        Dim send_username As String, send_cop As String, send_mail As String, send_phone As String  

        Dim cmbType As String, cmbW As Integer, cmbC As Integer, cmbH As Integer  

        ' add lasttime  

        Do While mSqlite.sqlite3_step(f_lStatement) = SQLITE_ROW  

            Debug.Print mSqlite.sqlite3_column_int(f_lStatement, 0)  

            Debug.Print mSqlite.sqlite3_column_text(f_lStatement, 1)  

            send_username = mSqlite.sqlite3_column_text(f_lStatement, 2)  

            send_cop = mSqlite.sqlite3_column_text(f_lStatement, 3)  

            send_mail = mSqlite.sqlite3_column_text(f_lStatement, 4)  

            send_phone = mSqlite.sqlite3_column_text(f_lStatement, 5)  

            cmbType = mSqlite.sqlite3_column_text(f_lStatement, 6)  

            cmbW = mSqlite.sqlite3_column_int(f_lStatement, 7)  

            cmbC = mSqlite.sqlite3_column_int(f_lStatement, 8)  

            cmbH = mSqlite.sqlite3_column_int(f_lStatement, 9)  

            generate send_username, send_cop, send_mail, send_phone, cmbType, cmbW, cmbC, cmbH  

            mSqlite.sqlite3_exec f_lSqlite, "UPDATE history set flag=1 WHERE id=" & mSqlite.sqlite3_column_int(f_lStatement, 0)  

        Loop  

    Else  

        Debug.Print mSqlite.sqlite3_errmsg(f_lSqlite)  

    End If  

    Call mSqlite.sqlite3_finalize(f_lStatement)  

    '// Close DB handle  

    Call mSqlite.sqlite3_close(f_lSqlite)  

    '// Terminate wrapper  

    Call mSqlite.sqlite3_shutdown  

End Sub  

我的项目目录结构是：

data

       ---data.sqlite

vb

---

自己使用的时候要注意修改数据库路径。