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