Microsoft Access modSql

Constants

Public Const strFormatSqlDate As String = "yyyy\-mm\-dd"
Public Const strFormatSqlDateCriterion As String = "\#yyyy\-mm\-dd\#"

executeSql

SQL statements with references to Access objects would work with DoCmd.RunSQL but the use of references to form fields and other Access objects is not advisable, therefore this option for handling possible errors has deliberately been omitted.

Public Function executeSql( _
    strSql As String, _
    Optional strDatabase As String = "", _
    Optional blnReturnId As Boolean = True _
    ) As Long
    Dim lngResult As Long
 
    Dim db As Database
    Dim datStart As Date
    Dim strErr As String
    Dim strTable As String
    Dim strAffected As String
    Dim strResult As String
 
    lngResult = 0
 
    If isDebug Then
        Debug.Print "----------------------------------------"
        Debug.Print strSql
        datStart = Now
        Debug.Print "+---------------------+"
        Debug.Print "|    Start : " & Format(datStart, strFormatTime) & " |"
    End If
    
    If strDatabase = "" Or strDatabase = CurrentProject.FullName Then
        Set db = CurrentDb
    Else
        Set db = OpenDatabase(strDatabase)
    End If
    
    With db
        On Error GoTo handleExecuteError
        If isDebug Then
            .Execute strSql, dbFailOnError
        Else
            .Execute strSql
        End If
        On Error GoTo 0
        DoEvents
 
        strAffected = "|  Records "
        lngResult = .RecordsAffected
        If lngResult = 1 Then
            If blnReturnId Then
                'Last inserted id
                lngResult = .OpenRecordset("SELECT @@IDENTITY")(0)
                If lngResult = 0 Then
                    lngResult = 1
                Else
                    strAffected = "|  Last Id "
                End If
            End If
        End If
    End With
 
    If isDebug Then
        strResult = Format(lngResult, "#,##0")
        If Len(strResult) < 8 Then
            strResult = strResult & Space(8 - Len(strResult) + 1) & "|"
        End If
        Debug.Print "|      End : " & Format(Now, strFormatTime) & " |"
        Debug.Print "| Duration : " & Format(Now - datStart, strFormatTime) & " |"
        Debug.Print strAffected & ": " & strResult
        Debug.Print "+---------------------+"
        Debug.Print "----------------------------------------"
        Debug.Print
    End If
 
    executeSql = lngResult
    Exit Function
 
handleExecuteError:
    Select Case Err.Number
 
    Case 2008: 'Table is open
        DoCmd.Close acTable, strTable, acSaveNo
        Resume
        
    Case 3010: 'Table already exists
        strErr = Err.Description
        strTable = Mid( _
            Err.Description, _
            InStr(1, strErr, "'", vbTextCompare) + 1, _
            InStrRev(strErr, "'", -1, vbTextCompare) - _
                InStr(1, strErr, "'", vbTextCompare) - 1 _
            )
        DoCmd.Close acTable, strTable, acSaveNo
        DoCmd.DeleteObject acTable, strTable
        Resume
 
    Case 3022: 'Duplicate key, duplicate values in index
        If isDebug Then
            Stop
        End If
        db.Execute strSql
        Resume Next
        
    Case 3051: 'Table is currently in use / locked
        Debug.Print "|  Restart : " & Format(datStart, strFormatTime) & " |"
        DoEvents
        Resume
 
    Case Else
        strErr = Err.Number & " : " & Err.Description
        Debug.Print "############"
        Debug.Print "# ERR " & Err.Number & " : " & Err.Description
        Debug.Print "# ABORT"
        Debug.Print "############"
        Debug.Print
        If isDebug Then
            Stop
            Resume
        End If
 
    End Select
End Function

showSqlResult

Public Sub showSqlResult(strSql As String, Optional strQuery As String = "")
    Dim dbs As Database
    Dim qdf As QueryDef
    
    If strQuery = "" Then
        strQuery = "SQL Result"
    End If
    If existsQuery(strQuery) Then
        DoCmd.DeleteObject acQuery, strQuery
    End If
    Set dbs = CurrentDb
    Set qdf = dbs.CreateQueryDef(Name:=strQuery, SQLText:=strSql)
    DoCmd.OpenQuery strQuery
    Do While CurrentData.AllQueries(strQuery).IsLoaded
        DoEvents
    Loop
    DoCmd.DeleteObject acQuery, strQuery
End Sub

getSqlAmount

Public Function getSqlAmount(cur As Currency) As String
    Dim strResult As String
    
    strResult = CStr(cur)
    strResult = Replace( _
        Expression:=strResult, _
        Find:=",", _
        Replace:=".", _
        Compare:=vbTextCompare _
        )
    
    getSqlAmount = strResult
End Function

getSqlDate

Public Function getSqlDate(dat As Date) As String
    Dim strResult As String
    
    strResult = Format(dat, strFormatSqlDate)
    
    getSqlDate = strResult
End Function

getSqlDateCriterion

Public Function getSqlDateCriterion(dat As Date) As String
    Dim strResult As String
    
    strResult = Format(dat, strFormatSqlDateCriterion)
    
    getSqlDateCriterion = strResult
End Function