openaccess/source/modules/OA_Utils.bas

Option Compare Database
Option Private Module
Option Explicit

Public Function oa_tbl_exists() As Boolean
' return True if the 'USysOpenAccess' table exists
On Error GoTo err
    oa_tbl_exists = (CurrentDb.TableDefs("USysOpenAccess").name = "USysOpenAccess")
Exit Function
err:
    If err.Number = 3265 Then
        oa_tbl_exists = False
    Else
        OA_MsgBox "Error: " & err.Description, vbCritical
    End If
End Function


Public Function update_oa_param(ByVal key As String, ByVal val As String)
' create or update the parameter in USysOpenAccess

    If Not oa_tbl_exists() Then
        Call create_oa_tbl
    End If

    If DCount("key", "USysOpenAccess", "[key]='" & key & "'") = 1 Then
'        CurrentDb.Execute "UPDATE USysOpenAccess SET USysOpenAccess.val = '" & val & "' " & _
'                            "WHERE (((USysOpenAccess.key)='" & key & "'));"
        run_sql "UPDATE USysOpenAccess SET USysOpenAccess.val = '" & val & "' " & _
                            "WHERE (((USysOpenAccess.key)='" & key & "'));"
    Else
'        CurrentDb.Execute "INSERT INTO USysOpenAccess ( val, [key] ) " & _
'                           "SELECT '" & val & "' AS Expr1, '" & key & "' AS Expr2;"
                        
        run_sql "INSERT INTO USysOpenAccess ( val, [key] ) " & _
                           "SELECT '" & val & "' AS Expr1, '" & key & "' AS Expr2;"
    End If

End Function

Public Function create_oa_tbl()
'creates the 'USysOpenAccess' table and hide it
    
    'CurrentDb.Execute "SELECT 'include_tables' as key, 'USysOpenAccess' as val INTO USysOpenAccess;"
    run_sql "SELECT 'include_tables' as key, 'USysOpenAccess' as val INTO USysOpenAccess;"
    Application.SetHiddenAttribute acTable, "USysOpenAccess", True

End Function

Public Function get_include_tables()
    
    get_include_tables = oa_param("include_tables")

End Function

Public Function oa_param(ByVal key As String, Optional ByVal default_value As String = "") As String
    oa_param = default_value
    On Error GoTo err_oa_table
    oa_param = DFirst("val", "USysOpenAccess", "[key]='" & key & "'")
err_oa_table:
End Function

Public Function IsInArray(ByVal stringToBeFound As String, ByRef arr As Variant) As Boolean
' returns True if the string is in the array
    IsInArray = (UBound(filter(arr, stringToBeFound)) > -1)
End Function

Public Function msys_type_filter(acType) As String
'returns a sql filter string for the object type
'NB: do not return system tables
'NB2: here are the types in msysobjects table:
'-32768 = Form
'-32766 = Macro
'-32764 = Report
'32761 = Module
'-32758  Users
'-32757  Database Document
'-32756  Data Access Pages
'1   Table - Local Access Tables
'2   Access Object - Database
'3   Access Object - Containers
'4   Table - Linked ODBC Tables
'5   Queries
'6   Table - Linked Access Tables
'8   SubDataSheets

    Select Case acType
        Case acTable
            msys_type_filter = "(([Type]=1 or [Type]=4 or [Type]=6) AND ([name] Not Like 'MSys*' AND [name] Not Like 'f_*_Data'))"
        Case acQuery
            msys_type_filter = "[Type]=5"
        Case acForm
            msys_type_filter = "[Type]=-32768"
        Case acReport
            msys_type_filter = "[Type]=-32764"
        Case acModule
            msys_type_filter = "[Type]=-32761"
        Case acMacro
            msys_type_filter = "[Type]=-32766"
        Case Else
            GoTo typerror
    End Select

Exit Function
typerror:
    OA_MsgBox "typerror:" & acType & " is not a valid object type"
    msys_type_filter = ""
End Function

Public Function remove_ext(ByVal filename As String) As String
    ' removes the extension of a file name
    If Not InStr(filename, ".") > 0 Then
        remove_ext = filename
        Exit Function
    End If

    Dim splitted_name As Variant
    splitted_name = Split(filename, ".")

    Dim i As Integer
    remove_ext = ""
    For i = 0 To (UBound(Split(filename, ".")) - 1)
        If Len(remove_ext) > 0 Then remove_ext = remove_ext & "."
        remove_ext = remove_ext & Split(filename, ".")(i)
    Next i

End Function

Public Function complete_gitignore()
' creates or complete the .gitignore file of the repo

    Dim gitignore_path, str_existing_keys, str As String
    Dim key As Variant
    Dim keys() As String
    
    keys = Split("*.accdb;*.laccdb;*.mdb;*.ldb;*.accde;*.mde;*.accda", ";")
    
    gitignore_path = CurrentProject.path & "\.gitignore"
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFile As Object
    If Not fso.FileExists(gitignore_path) Then
        Set oFile = fso.CreateTextFile(gitignore_path)
    Else
        Set oFile = fso.OpenTextFile(gitignore_path, ForReading)
        str_existing_keys = ""
        
        While Not oFile.AtEndOfStream
            str = oFile.readline
            If Len(str_existing_keys) = 0 Then
                str_existing_keys = str
            Else
                str_existing_keys = str_existing_keys & ";" & str
            End If
        Wend
        oFile.Close
        
        Dim existing_keys() As String
        existing_keys = Split(str_existing_keys, ";")
        
        Set oFile = fso.OpenTextFile(gitignore_path, ForAppending)
    End If
    
    oFile.WriteBlankLines (2)
    oFile.WriteLine ("#[ automatically added by OpenAccess")
    For Each key In keys
        If Not IsInArray(key, existing_keys) Then
            oFile.WriteLine key
        End If
    Next key
    oFile.WriteLine "#]"
    oFile.WriteBlankLines (2)
    
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Function

Public Sub SaveProject()
    On Error Resume Next
    CurrentProject.Application.RunCommand acCmdSave
    Exit Sub
End Sub

Public Sub run_sql(ByVal sql As String)
    On Error GoTo next_try
    
    CurrentDb.Execute sql
    Exit Sub
    
next_try:
    err.Clear
    On Error GoTo err
    Dim cnn As New ADODB.Connection
    Set cnn = CurrentProject.Connection
    cnn.Execute (sql)
    Set cnn = Nothing
    Exit Sub
    
err:
    logger "run_sql", "CRITICAL", "Error while running the SQL statement: " & sql
End Sub