openaccess/source/modules/vcs.bas

Option Compare Database
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

Public Function vcsprompt()
Dim prompt, prompttext, warning As String

prompttext = "Write your command here:" & vbNewLine & _
             "> 'makesources' to create or update the source files" & vbNewLine & _
             "> 'update' to update the current application within the source files" & vbNewLine & _
             "(see docs for more commands)"
prompt = InputBox(prompttext, "VCS")

Select Case prompt

Case "makesources"

    Call make_sources

Case "update"

    Call update_from_sources

Case ""
    MsgBox "Operation cancelled"

Case Else
    MsgBox "Unknown command"

End Select


End Function


Public Function make_sources()
'creates the source-code of the app

    Debug.Print "Zip the app file"
    Call zip_app_file
    Debug.Print "> done"
    
    Debug.Print get_include_tables
    
    Debug.Print "Run VCS Export"
    Call ExportAllSource
    Debug.Print "> done"

    MsgBox "Done"

End Function


Public Function update_from_sources()
'updates the application from the sources

    Debug.Print "Creates a backup of the app file"
    Call make_backup
    Debug.Print "> done"

    If MsgBox("WARNING: the current application is going to be updated " & _
                "with the source files. " & _
                "Any non committed work would be lost, " & _
                "are you sure you want to continue?" & _
                "", vbOKCancel) = vbCancel Then Exit Function

    Debug.Print "Run VCS Import"
    Call ImportAllSource
    Debug.Print "> done"

    MsgBox "Done"
    
End Function

Public Function config_git_repo()
'configure the application GIT repository for VCS use

'verify that it is a git repository
If Dir(CurrentProject.Path & "\.git") = "" Then
    MsgBox "Not a git repository, please use 'git init on this directory first"
    Exit Function
End If

' complete the gitignore file
Call complete_gitignore


End Function

Public Function get_include_tables()
    get_include_tables = vcs_param("include_tables")
End Function

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

Public Function zip_app_file() As Boolean
On Error GoTo err
Dim command As String

zip_app_file = False

'run the shell comand
command = "cmd.exe  /k cd " & CurrentProject.Path & " & " & _
      "zip tmp_" & CurrentProject.name & ".zip " & CurrentProject.name & _
      " & exit"
Shell command, vbHide
      
' waits for the compression ends
Dim count As Integer
count = 0
Do Until Dir(CurrentProject.Path & "\tmp_" & CurrentProject.name & ".zip") <> ""
    Sleep (0.01)
    count = count + 1
    If count > 5000 Then GoTo UnknownErr
Loop

'remove the old zip file
If Dir(CurrentProject.Path & "\" & CurrentProject.name & ".zip") <> "" Then
    Kill CurrentProject.Path & "\" & CurrentProject.name & ".zip"
End If

'rename the temporary zip
command = "cmd.exe  /k cd " & CurrentProject.Path & " & " & _
      "ren tmp_" & CurrentProject.name & ".zip" & " " & CurrentProject.name & ".zip" & _
      " & exit"
Shell command, vbHide

zip_app_file = True

fin:
    Exit Function
UnknownErr:
    MsgBox "Unknown error: unable to ZIP the app file, do it manually"
    GoTo fin
err:
    MsgBox "Error while zipping file app: " & err.Description
    GoTo fin
End Function

Public Function make_backup() As Boolean
On Error GoTo err

make_backup = True
If Dir(CurrentProject.Path & "\" & CurrentProject.name & ".old") <> "" Then
    Kill CurrentProject.Path & "\" & CurrentProject.name & ".old"
End If

FileCopy CurrentProject.Path & "\" & CurrentProject.name, CurrentProject.Path & "\" & CurrentProject.name & ".old"

make_backup = True
Exit Function
err:
    MsgBox "Error during backup:" & err.Description
End Function

Public Function complete_gitignore()
' creates or complete the .gitignore file of the repo
Dim gitignore_path As String

Dim keys() As String
keys = Split("*.accdb;*.laccdb;*.mdb;*.ldb", ";")

gitignore_path = CurrentProject.Path & "\.gitignore"

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim oFile As Object
    
    If Dir(gitignore_path) = "" Then
        Set oFile = fso.CreateTextFile(gitignore_path)
    Else
        Set oFile = fso.OpenTextFile(gitignore_path, ForAppending)
    End If
    
    oFile.WriteBlankLines (2)
    oFile.WriteLine ("#[ automatically added by VCS")
    For Each key In keys
        oFile.WriteLine key
    Next key
    oFile.WriteLine "#]"
    oFile.WriteBlankLines (2)
    
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Function