vcs exporte maintenant ses propres modules; activer/desactiver l'optimizer; dates de derniere modif des objets ok

.gitignore

@@ -1,5 +1,5 @@
 *.komodoproject
-
+test\
 *.accdb
 *.laccdb
 *.accda

source/forms/frm_vcs.bas

@@ -441,7 +441,7 @@ Sub run()
     If Not Me.txt_args.Enabled Then
         Application.run Me.cb_command.Column(1)
     Else
-        Application.run Me.cb_command.Column(1), Me.txt_args
+        Application.run Me.cb_command.Column(1), Nz(Me.txt_args, "")
     End If
     MsgBox "Done"
 

source/modules/VCS_DataMacro.bas

@@ -0,0 +1,77 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+
+' For Access 2007 (VBA6) and earlier
+#If Not VBA7 Then
+  Private Const acTableDataMacro As Integer = 12
+#End If
+
+Public Sub ExportDataMacros(ByVal tableName As String, ByVal directory As String)
+    On Error GoTo Err_export
+    Dim filePath As String
+    
+    filePath = directory & tableName & ".xml"
+
+    VCS_IE_Functions.ExportObject acTableDataMacro, tableName, filePath, VCS_File.UsingUcs2
+    FormatDataMacro filePath
+
+    Exit Sub
+
+Err_export:
+    ' Error to export dataMacro, no contains dataMacro. Do nothing
+End Sub
+
+Public Sub ImportDataMacros(ByVal tableName As String, ByVal directory As String)
+    On Error GoTo Err_import
+    Dim filePath As String
+    
+    filePath = directory & tableName & ".xml"
+    VCS_IE_Functions.ImportObject acTableDataMacro, tableName, filePath, VCS_File.UsingUcs2
+    
+    Exit Sub
+    
+Err_import:
+    ' Error to import dataMacro. Do nothing
+End Sub
+
+'Splits exported DataMacro XML onto multiple lines
+'Allows git to find changes within lines using diff
+Private Sub FormatDataMacro(ByVal filePath As String)
+
+    Dim saveStream As Object 'ADODB.Stream
+
+    Set saveStream = CreateObject("ADODB.Stream")
+    saveStream.Charset = "utf-8"
+    saveStream.Type = 2 'adTypeText
+    saveStream.Open
+
+    Dim objStream As Object 'ADODB.Stream
+    Dim strData As String
+    Set objStream = CreateObject("ADODB.Stream")
+
+    objStream.Charset = "utf-8"
+    objStream.Type = 2 'adTypeText
+    objStream.Open
+    objStream.LoadFromFile (filePath)
+    
+    Do While Not objStream.EOS
+        strData = objStream.ReadText(-2) 'adReadLine
+
+        Dim tag As Variant
+        
+        For Each tag In Split(strData, ">")
+            If tag <> vbNullString Then
+                saveStream.WriteText tag & ">", 1 'adWriteLine
+            End If
+        Next
+        
+    Loop
+    
+    objStream.Close
+    saveStream.SaveToFile filePath, 2 'adSaveCreateOverWrite
+    saveStream.Close
+
+End Sub

source/modules/VCS_Dir.bas

@@ -0,0 +1,59 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+
+' Path/Directory of the current database file.
+Public Function ProjectPath() As String
+    ProjectPath = CurrentProject.Path
+    If Right$(ProjectPath, 1) <> "\" Then ProjectPath = ProjectPath & "\"
+End Function
+
+' Path/Directory for source files
+Public Function SourcePath() As String
+    SourcePath = ProjectPath & CurrentProject.name & ".src\"
+End Function
+
+' Create folder `Path`. Silently do nothing if it already exists.
+Public Sub MkDirIfNotExist(ByVal Path As String)
+    On Error GoTo MkDirIfNotexist_noop
+    MkDir Path
+MkDirIfNotexist_noop:
+    On Error GoTo 0
+End Sub
+
+' Delete a file if it exists.
+Public Sub DelIfExist(ByVal Path As String)
+    On Error GoTo DelIfNotExist_Noop
+    Kill Path
+DelIfNotExist_Noop:
+    On Error GoTo 0
+End Sub
+
+' Erase all *.`ext` files in `Path`.
+Public Sub ClearTextFilesFromDir(ByVal Path As String, ByVal Ext As String)
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    If Not fso.FolderExists(Path) Then Exit Sub
+
+    On Error GoTo ClearTextFilesFromDir_noop
+    If dir$(Path & "*." & Ext) <> vbNullString Then
+        fso.DeleteFile Path & "*." & Ext
+    End If
+    
+ClearTextFilesFromDir_noop:
+    On Error GoTo 0
+End Sub
+
+Public Function DirExists(ByVal strPath As String) As Boolean
+    On Error Resume Next
+    DirExists = False
+    DirExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
+End Function
+
+Public Function FileExists(ByVal strPath As String) As Boolean
+    On Error Resume Next
+    FileExists = False
+    FileExists = ((GetAttr(strPath) And vbDirectory) <> vbDirectory)
+End Function

source/modules/VCS_File.bas

@@ -0,0 +1,273 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+#If VBA7 Then
+  Private Declare PtrSafe _
+      Function getTempPath Lib "kernel32" _
+           Alias "GetTempPathA" (ByVal nBufferLength As Long, _
+                                 ByVal lpBuffer As String) As Long
+  Private Declare PtrSafe _
+      Function getTempFileName Lib "kernel32" _
+           Alias "GetTempFileNameA" (ByVal lpszPath As String, _
+                                     ByVal lpPrefixString As String, _
+                                     ByVal wUnique As Long, _
+                                     ByVal lpTempFileName As String) As Long
+#Else
+  Private Declare _
+      Function getTempPath Lib "kernel32" _
+           Alias "GetTempPathA" (ByVal nBufferLength As Long, _
+                                 ByVal lpBuffer As String) As Long
+  Private Declare _
+      Function getTempFileName Lib "kernel32" _
+           Alias "GetTempFileNameA" (ByVal lpszPath As String, _
+                                     ByVal lpPrefixString As String, _
+                                     ByVal wUnique As Long, _
+                                     ByVal lpTempFileName As String) As Long
+#End If
+
+' --------------------------------
+' Structures
+' --------------------------------
+
+' Structure to track buffered reading or writing of binary files
+Private Type BinFile
+    file_num As Integer
+    file_len As Long
+    file_pos As Long
+    buffer As String
+    buffer_len As Integer
+    buffer_pos As Integer
+    at_eof As Boolean
+    mode As String
+End Type
+
+
+' --------------------------------
+' Basic functions missing from VB 6: buffered file read/write, string builder, encoding check & conversion
+' --------------------------------
+
+' Open a binary file for reading (mode = 'r') or writing (mode = 'w').
+Private Function BinOpen(ByVal file_path As String, ByVal mode As String) As BinFile
+    Dim f As BinFile
+
+    f.file_num = FreeFile
+    f.mode = LCase$(mode)
+    If f.mode = "r" Then
+        Open file_path For Binary Access Read As f.file_num
+        f.file_len = LOF(f.file_num)
+        f.file_pos = 0
+        If f.file_len > &H4000 Then
+            f.buffer = String$(&H4000, " ")
+            f.buffer_len = &H4000
+        Else
+            f.buffer = String$(f.file_len, " ")
+            f.buffer_len = f.file_len
+        End If
+        f.buffer_pos = 0
+        Get f.file_num, f.file_pos + 1, f.buffer
+    Else
+        DelIfExist file_path
+        Open file_path For Binary Access Write As f.file_num
+        f.file_len = 0
+        f.file_pos = 0
+        f.buffer = String$(&H4000, " ")
+        f.buffer_len = 0
+        f.buffer_pos = 0
+    End If
+
+    BinOpen = f
+End Function
+
+' Buffered read one byte at a time from a binary file.
+Private Function BinRead(ByRef f As BinFile) As Integer
+    If f.at_eof = True Then
+        BinRead = 0
+        Exit Function
+    End If
+
+    BinRead = Asc(Mid$(f.buffer, f.buffer_pos + 1, 1))
+
+    f.buffer_pos = f.buffer_pos + 1
+    If f.buffer_pos >= f.buffer_len Then
+        f.file_pos = f.file_pos + &H4000
+        If f.file_pos >= f.file_len Then
+            f.at_eof = True
+            Exit Function
+        End If
+        If f.file_len - f.file_pos > &H4000 Then
+            f.buffer_len = &H4000
+        Else
+            f.buffer_len = f.file_len - f.file_pos
+            f.buffer = String$(f.buffer_len, " ")
+        End If
+        f.buffer_pos = 0
+        Get f.file_num, f.file_pos + 1, f.buffer
+    End If
+End Function
+
+' Buffered write one byte at a time from a binary file.
+Private Sub BinWrite(ByRef f As BinFile, b As Integer)
+    Mid(f.buffer, f.buffer_pos + 1, 1) = Chr$(b)
+    f.buffer_pos = f.buffer_pos + 1
+    If f.buffer_pos >= &H4000 Then
+        Put f.file_num, , f.buffer
+        f.buffer_pos = 0
+    End If
+End Sub
+
+' Close binary file.
+Private Sub BinClose(ByRef f As BinFile)
+    If f.mode = "w" And f.buffer_pos > 0 Then
+        f.buffer = Left$(f.buffer, f.buffer_pos)
+        Put f.file_num, , f.buffer
+    End If
+    Close f.file_num
+End Sub
+
+
+' Binary convert a UCS2-little-endian encoded file to UTF-8.
+Public Sub ConvertUcs2Utf8(ByVal Source As String, ByVal dest As String)
+    Dim f_in As BinFile
+    Dim f_out As BinFile
+    Dim in_low As Integer
+    Dim in_high As Integer
+
+    f_in = BinOpen(Source, "r")
+    f_out = BinOpen(dest, "w")
+
+    Do While Not f_in.at_eof
+        in_low = BinRead(f_in)
+        in_high = BinRead(f_in)
+        If in_high = 0 And in_low < &H80 Then
+            ' U+0000 - U+007F   0LLLLLLL
+            BinWrite f_out, in_low
+        ElseIf in_high < &H8 Then
+            ' U+0080 - U+07FF   110HHHLL 10LLLLLL
+            BinWrite f_out, &HC0 + ((in_high And &H7) * &H4) + ((in_low And &HC0) / &H40)
+            BinWrite f_out, &H80 + (in_low And &H3F)
+        Else
+            ' U+0800 - U+FFFF   1110HHHH 10HHHHLL 10LLLLLL
+            BinWrite f_out, &HE0 + ((in_high And &HF0) / &H10)
+            BinWrite f_out, &H80 + ((in_high And &HF) * &H4) + ((in_low And &HC0) / &H40)
+            BinWrite f_out, &H80 + (in_low And &H3F)
+        End If
+    Loop
+
+    BinClose f_in
+    BinClose f_out
+End Sub
+
+' Binary convert a UTF-8 encoded file to UCS2-little-endian.
+Public Sub ConvertUtf8Ucs2(ByVal Source As String, ByVal dest As String)
+    Dim f_in As BinFile
+    Dim f_out As BinFile
+    Dim in_1 As Integer
+    Dim in_2 As Integer
+    Dim in_3 As Integer
+
+    f_in = BinOpen(Source, "r")
+    f_out = BinOpen(dest, "w")
+
+    Do While Not f_in.at_eof
+        in_1 = BinRead(f_in)
+        If (in_1 And &H80) = 0 Then
+            ' U+0000 - U+007F   0LLLLLLL
+            BinWrite f_out, in_1
+            BinWrite f_out, 0
+        ElseIf (in_1 And &HE0) = &HC0 Then
+            ' U+0080 - U+07FF   110HHHLL 10LLLLLL
+            in_2 = BinRead(f_in)
+            BinWrite f_out, ((in_1 And &H3) * &H40) + (in_2 And &H3F)
+            BinWrite f_out, (in_1 And &H1C) / &H4
+        Else
+            ' U+0800 - U+FFFF   1110HHHH 10HHHHLL 10LLLLLL
+            in_2 = BinRead(f_in)
+            in_3 = BinRead(f_in)
+            BinWrite f_out, ((in_2 And &H3) * &H40) + (in_3 And &H3F)
+            BinWrite f_out, ((in_1 And &HF) * &H10) + ((in_2 And &H3C) / &H4)
+        End If
+    Loop
+
+    BinClose f_in
+    BinClose f_out
+End Sub
+
+' Determine if this database imports/exports code as UCS-2-LE. (Older file
+' formats cause exported objects to use a Windows 8-bit character set.)
+Public Function UsingUcs2() As Boolean
+    Dim obj_name As String
+    Dim obj_type As Variant
+    Dim fn As Integer
+    Dim bytes As String
+    Dim obj_type_split() As String
+    Dim obj_type_name As String
+    Dim obj_type_num As Integer
+    
+    If CurrentDb.QueryDefs.count > 0 Then
+        obj_type_num = acQuery
+        obj_name = CurrentDb.QueryDefs(0).name
+    Else
+        For Each obj_type In Split( _
+            "Forms|" & acForm & "," & _
+            "Reports|" & acReport & "," & _
+            "Scripts|" & acMacro & "," & _
+            "Modules|" & acModule _
+        )
+            DoEvents
+            obj_type_split = Split(obj_type, "|")
+            obj_type_name = obj_type_split(0)
+            obj_type_num = val(obj_type_split(1))
+            If CurrentDb.Containers(obj_type_name).Documents.count > 0 Then
+                obj_name = CurrentDb.Containers(obj_type_name).Documents(0).name
+                Exit For
+            End If
+        Next
+    End If
+
+    If obj_name = vbNullString Then
+        ' No objects found that can be used to test UCS2 versus UTF-8
+        UsingUcs2 = True
+        Exit Function
+    End If
+
+    Dim tempFileName As String
+    tempFileName = VCS_File.TempFile()
+    
+    Application.SaveAsText obj_type_num, obj_name, tempFileName
+    fn = FreeFile
+    Open tempFileName For Binary Access Read As fn
+    bytes = "  "
+    Get fn, 1, bytes
+    If Asc(Mid$(bytes, 1, 1)) = &HFF And Asc(Mid$(bytes, 2, 1)) = &HFE Then
+        UsingUcs2 = True
+    Else
+        UsingUcs2 = False
+    End If
+    Close fn
+    
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    fso.DeleteFile (tempFileName)
+End Function
+
+' Generate Random / Unique tempprary file name.
+Public Function TempFile(Optional ByVal sPrefix As String = "VBA") As String
+    Dim sTmpPath As String * 512
+    Dim sTmpName As String * 576
+    Dim nRet As Long
+    Dim sFileName As String
+    
+    nRet = getTempPath(512, sTmpPath)
+    nRet = getTempFileName(sTmpPath, sPrefix, 0, sTmpName)
+    If nRet <> 0 Then sFileName = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
+    TempFile = sFileName
+End Function
+
+Public Function IsValidFileName(ByVal sName As String) As Boolean
+
+    IsValidFileName = (InStr(sName, "\") = 0 And InStr(sName, "/") = 0 And InStr(sName, "*") = 0 And InStr(sName, "?") = 0 And InStr(sName, Chr(34)) = 0 And InStr(sName, "|") = 0 And InStr(sName, ":") = 0 And InStr(sName, ">") = 0 And InStr(sName, "<") = 0)
+                        
+
+End Function

source/modules/VCS_IE_Functions.bas

@@ -0,0 +1,181 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+Private Const AggressiveSanitize As Boolean = True
+Private Const StripPublishOption As Boolean = True
+
+' Constants for Scripting.FileSystemObject API
+Public Const ForReading = 1, ForWriting = 2, ForAppending = 8
+Public Const TristateTrue = -1, TristateFalse = 0, TristateUseDefault = -2
+
+
+' Can we export without closing the form?
+
+' Export a database object with optional UCS2-to-UTF-8 conversion.
+Public Sub ExportObject(ByVal obj_type_num As Integer, ByVal obj_name As String, _
+                    ByVal file_path As String, Optional ByVal Ucs2Convert As Boolean = False)
+
+
+    VCS_Dir.MkDirIfNotExist Left$(file_path, InStrRev(file_path, "\"))
+    If Ucs2Convert Then
+        Dim tempFileName As String
+        tempFileName = VCS_File.TempFile()
+        Application.SaveAsText obj_type_num, obj_name, tempFileName
+        VCS_File.ConvertUcs2Utf8 tempFileName, file_path
+    Else
+        Application.SaveAsText obj_type_num, obj_name, file_path
+    End If
+End Sub
+
+' Import a database object with optional UTF-8-to-UCS2 conversion.
+Public Sub ImportObject(ByVal obj_type_num As Integer, ByVal obj_name As String, _
+                    ByVal file_path As String, Optional ByVal Ucs2Convert As Boolean = False)
+    
+    If Not VCS_Dir.FileExists(file_path) Then Exit Sub
+    
+    If Ucs2Convert Then
+        Dim tempFileName As String
+        tempFileName = VCS_File.TempFile()
+        VCS_File.ConvertUtf8Ucs2 file_path, tempFileName
+        Application.LoadFromText obj_type_num, obj_name, tempFileName
+        
+        Dim fso As Object
+        Set fso = CreateObject("Scripting.FileSystemObject")
+        fso.DeleteFile tempFileName
+    Else
+        Application.LoadFromText obj_type_num, obj_name, file_path
+    End If
+End Sub
+
+'shouldn't this be SanitizeTextFile (Singular)?
+
+' For each *.txt in `Path`, find and remove a number of problematic but
+' unnecessary lines of VB code that are inserted automatically by the
+' Access GUI and change often (we don't want these lines of code in
+' version control).
+Public Sub SanitizeTextFiles(ByVal Path As String, ByVal Ext As String)
+
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    '
+    '  Setup Block matching Regex.
+    Dim rxBlock As Object
+    Set rxBlock = CreateObject("VBScript.RegExp")
+    rxBlock.ignoreCase = False
+    '
+    '  Match PrtDevNames / Mode with or  without W
+    Dim srchPattern As String
+    srchPattern = "PrtDev(?:Names|Mode)[W]?"
+    If (AggressiveSanitize = True) Then
+      '  Add and group aggressive matches
+      srchPattern = "(?:" & srchPattern
+      srchPattern = srchPattern & "|GUID|""GUID""|NameMap|dbLongBinary ""DOL"""
+      srchPattern = srchPattern & ")"
+    End If
+    '  Ensure that this is the begining of a block.
+    srchPattern = srchPattern & " = Begin"
+'Debug.Print srchPattern
+    rxBlock.Pattern = srchPattern
+    '
+    '  Setup Line Matching Regex.
+    Dim rxLine As Object
+    Set rxLine = CreateObject("VBScript.RegExp")
+    srchPattern = "^\s*(?:"
+    srchPattern = srchPattern & "Checksum ="
+    srchPattern = srchPattern & "|BaseInfo|NoSaveCTIWhenDisabled =1"
+    If (StripPublishOption = True) Then
+        srchPattern = srchPattern & "|dbByte ""PublishToWeb"" =""1"""
+        srchPattern = srchPattern & "|PublishOption =1"
+    End If
+    srchPattern = srchPattern & ")"
+'Debug.Print srchPattern
+    rxLine.Pattern = srchPattern
+    Dim fileName As String
+    fileName = dir$(Path & "*." & Ext)
+    Dim isReport As Boolean
+    isReport = False
+    
+    Do Until Len(fileName) = 0
+        DoEvents
+        Dim obj_name As String
+        obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+
+        Dim InFile As Object
+        Set InFile = fso.OpenTextFile(Path & obj_name & "." & Ext, iomode:=ForReading, create:=False, Format:=TristateFalse)
+        Dim OutFile As Object
+        Set OutFile = fso.CreateTextFile(Path & obj_name & ".sanitize", overwrite:=True, Unicode:=False)
+    
+        Dim getLine As Boolean
+        getLine = True
+        
+        Do Until InFile.AtEndOfStream
+            DoEvents
+            Dim txt As String
+            '
+            ' Check if we need to get a new line of text
+            If getLine = True Then
+                txt = InFile.readline
+            Else
+                getLine = True
+            End If
+            '
+            ' Skip lines starting with line pattern
+            If rxLine.test(txt) Then
+                Dim rxIndent As Object
+                Set rxIndent = CreateObject("VBScript.RegExp")
+                rxIndent.Pattern = "^(\s+)\S"
+                '
+                ' Get indentation level.
+                Dim matches As Object
+                Set matches = rxIndent.execute(txt)
+                '
+                ' Setup pattern to match current indent
+                Select Case matches.count
+                    Case 0
+                        rxIndent.Pattern = "^" & vbNullString
+                    Case Else
+                        rxIndent.Pattern = "^" & matches(0).SubMatches(0)
+                End Select
+                rxIndent.Pattern = rxIndent.Pattern + "\S"
+                '
+                ' Skip lines with deeper indentation
+                Do Until InFile.AtEndOfStream
+                    txt = InFile.readline
+                    If rxIndent.test(txt) Then Exit Do
+                Loop
+                ' We've moved on at least one line so do get a new one
+                ' when starting the loop again.
+                getLine = False
+            '
+            ' skip blocks of code matching block pattern
+            ElseIf rxBlock.test(txt) Then
+                Do Until InFile.AtEndOfStream
+                    txt = InFile.readline
+                    If InStr(txt, "End") Then Exit Do
+                Loop
+            ElseIf InStr(1, txt, "Begin Report") = 1 Then
+                isReport = True
+                OutFile.WriteLine txt
+            ElseIf isReport = True And (InStr(1, txt, "    Right =") Or InStr(1, txt, "    Bottom =")) Then
+                'skip line
+                If InStr(1, txt, "    Bottom =") Then
+                    isReport = False
+                End If
+            Else
+                OutFile.WriteLine txt
+            End If
+        Loop
+        OutFile.Close
+        InFile.Close
+
+        fso.DeleteFile (Path & fileName)
+
+        Dim thisFile As Object
+        Set thisFile = fso.GetFile(Path & obj_name & ".sanitize")
+        thisFile.Move (Path & fileName)
+        fileName = dir$()
+    Loop
+
+End Sub

source/modules/VCS_ImportExport.bas

@@ -0,0 +1,706 @@
+Option Compare Database
+
+Option Explicit
+
+' List of lookup tables that are part of the program rather than the
+' data, to be exported with source code
+' Set to "*" to export the contents of all tables
+'Only used in ExportAllSource
+'Private Const include_tables As String = ""
+Private include_tables As String
+
+' This is used in ImportAllSource
+Private Const DebugOutput As Boolean = False
+'this is used in ExportAllSource
+'Causes the VCS_ code to be exported
+Private Const ArchiveMyself As Boolean = False
+
+
+'returns true if named module is NOT part of the VCS code
+Private Function IsNotVCS(ByVal name As String) As Boolean
+
+    '*** ajout 12.10.16: si l'addin vcs est lancé depuis sa version dev
+    If CurrentProject.name = "vcs.accda" Then
+        IsNotVCS = True
+        Exit Function
+    End If
+    '****
+
+    If name <> "VCS_ImportExport" And _
+      name <> "VCS_IE_Functions" And _
+      name <> "VCS_File" And _
+      name <> "VCS_Dir" And _
+      name <> "VCS_String" And _
+      name <> "VCS_Loader" And _
+      name <> "VCS_Table" And _
+      name <> "VCS_Reference" And _
+      name <> "VCS_DataMacro" And _
+      name <> "VCS_Report" And _
+      name <> "VCS_Relation" Then
+        IsNotVCS = True
+    Else
+        IsNotVCS = False
+    End If
+
+End Function
+
+' Main entry point for EXPORT. Export all forms, reports, queries,
+' macros, modules, and lookup tables to `source` folder under the
+' database's folder.
+Public Sub ExportAllSource()
+    Dim Db As Object ' DAO.Database
+    Dim source_path As String
+    Dim obj_path As String
+    Dim qry As Object ' DAO.QueryDef
+    Dim doc As Object ' DAO.Document
+    Dim obj_type As Variant
+    Dim obj_type_split() As String
+    Dim obj_type_label As String
+    Dim obj_type_name As String
+    Dim obj_type_num As Integer
+    Dim obj_count As Integer
+    Dim obj_data_count As Integer
+    Dim ucs2 As Boolean
+
+    include_tables = get_include_tables()
+    
+    Set Db = CurrentDb
+
+    CloseFormsReports
+    'InitUsingUcs2
+
+    source_path = VCS_Dir.ProjectPath() & "source\"
+    VCS_Dir.MkDirIfNotExist source_path
+
+
+    obj_path = source_path & "queries\"
+    VCS_Dir.ClearTextFilesFromDir obj_path, "bas"
+    
+    Debug.Print VCS_String.PadRight("Exporting queries...", 24);
+    
+    obj_count = 0
+    For Each qry In Db.QueryDefs
+    
+        '### 11/10/2016: add optimizer
+        If optimizer_activated() Then
+            If Not is_dirty(acQuery, qry.name) Then
+                obj_count = obj_count + 1
+                GoTo next_qry
+            End If
+        End If
+        '###
+
+        If Not IsValidFileName(qry.name) Then
+            Debug.Print "ERROR:" & qry.name & " is not a valid file name, query has been ignored"
+            obj_count = obj_count + 1
+            GoTo next_qry
+        End If
+        
+        DoEvents
+        If Left$(qry.name, 1) <> "~" Then
+            VCS_IE_Functions.ExportObject acQuery, qry.name, obj_path & qry.name & ".bas", VCS_File.UsingUcs2
+            obj_count = obj_count + 1
+        End If
+        
+next_qry:
+
+        Call SysCmd(4, "Export query: " & obj_count & " on " & Db.QueryDefs.count)
+    Next
+    
+    Call SysCmd(4, "Sanitize queries")
+    Debug.Print VCS_String.PadRight("Sanitizing...", 15);
+    VCS_IE_Functions.SanitizeTextFiles obj_path, "bas"
+    Debug.Print "[" & obj_count & "]"
+        
+    For Each obj_type In Split( _
+        "forms|Forms|" & acForm & "," & _
+        "reports|Reports|" & acReport & "," & _
+        "macros|Scripts|" & acMacro & "," & _
+        "modules|Modules|" & acModule _
+        , "," _
+    )
+        obj_type_split = Split(obj_type, "|")
+        obj_type_label = obj_type_split(0)
+        obj_type_name = obj_type_split(1)
+        obj_type_num = val(obj_type_split(2))
+        obj_path = source_path & obj_type_label & "\"
+        obj_count = 0
+        
+        'a retirer
+        VCS_Dir.ClearTextFilesFromDir obj_path, "bas"
+        
+        Debug.Print VCS_String.PadRight("Exporting " & obj_type_label & "...", 24);
+        
+        For Each doc In Db.Containers(obj_type_name).Documents
+        
+            '### 11/10/2016: add optimizer
+            If optimizer_activated() Then
+                If Not is_dirty(obj_type_num, doc.name) Then
+                    obj_count = obj_count + 1
+                    GoTo next_doc
+                End If
+            End If
+            '###
+        
+            DoEvents
+            
+            If Not IsValidFileName(doc.name) Then
+                Debug.Print "ERROR:" & doc.name & " is not a valid file name, " & obj_type_name & " has been ignored"
+                obj_count = obj_count + 1
+                GoTo next_doc
+            End If
+            
+            If (Left$(doc.name, 1) <> "~") And _
+               (IsNotVCS(doc.name) Or ArchiveMyself) Then
+                If obj_type_label = "modules" Then
+                    ucs2 = False
+                Else
+                    ucs2 = VCS_File.UsingUcs2
+                End If
+                VCS_IE_Functions.ExportObject obj_type_num, doc.name, obj_path & doc.name & ".bas", ucs2
+                
+                If obj_type_label = "reports" Then
+                    VCS_Report.ExportPrintVars doc.name, obj_path & doc.name & ".pv"
+                End If
+                
+                Call SysCmd(4, "Exporting " & obj_type_label & ": " & obj_count & " on " & Db.Containers(obj_type_name).Documents.count)
+
+                obj_count = obj_count + 1
+            End If
+                        
+next_doc:
+        Next
+
+        Call SysCmd(4, "Sanitizing")
+        Debug.Print VCS_String.PadRight("Sanitizing...", 15);
+        
+        If obj_type_label <> "modules" Then
+            VCS_IE_Functions.SanitizeTextFiles obj_path, "bas"
+        End If
+                
+        Debug.Print "[" & obj_count & "]"
+        
+    Next
+    
+    Call SysCmd(4, "Export references")
+    VCS_Reference.ExportReferences source_path
+
+'-------------------------table export------------------------
+
+    Call SysCmd(4, "Export tables")
+    obj_path = source_path & "tables\"
+    VCS_Dir.MkDirIfNotExist Left$(obj_path, InStrRev(obj_path, "\"))
+    VCS_Dir.ClearTextFilesFromDir obj_path, "txt"
+    
+    Dim td As DAO.TableDef
+    Dim tds As DAO.TableDefs
+    Set tds = Db.TableDefs
+
+    obj_type_label = "tbldef"
+    obj_type_name = "Table_Def"
+    obj_type_num = acTable
+    obj_path = source_path & obj_type_label & "\"
+    obj_count = 0
+    obj_data_count = 0
+    VCS_Dir.MkDirIfNotExist Left$(obj_path, InStrRev(obj_path, "\"))
+    
+    'move these into Table and DataMacro modules?
+    ' - We don't want to determin file extentions here - or obj_path either!
+    VCS_Dir.ClearTextFilesFromDir obj_path, "sql"
+    VCS_Dir.ClearTextFilesFromDir obj_path, "xml"
+    VCS_Dir.ClearTextFilesFromDir obj_path, "LNKD"
+    
+    Dim IncludeTablesCol As Collection
+    Set IncludeTablesCol = StrSetToCol(include_tables, ",")
+    
+    Debug.Print VCS_String.PadRight("Exporting " & obj_type_label & "...", 24);
+    
+    For Each td In tds
+    
+        '### 11/10/2016: add optimizer
+        If optimizer_activated() Then
+            If Not is_dirty(acTable, td.name) Then
+                obj_count = obj_count + 1
+                GoTo next_td
+            End If
+        End If
+        '###
+    
+        If Not IsValidFileName(td.name) Then
+            Debug.Print "ERROR:" & td.name & " is not a valid file name, table_def has been ignored"
+            obj_count = obj_count + 1
+            GoTo next_td
+        End If
+    
+    
+        ' This is not a system table
+        ' this is not a temporary table
+        If Left$(td.name, 4) <> "MSys" And _
+        Left$(td.name, 1) <> "~" Then
+            
+            If Len(td.connect) = 0 Then ' this is not an external table
+                VCS_Table.ExportTableDef Db, td, td.name, obj_path
+                If include_tables = "*" Then
+                    DoEvents
+                    VCS_Table.ExportTableData CStr(td.name), source_path & "tables\"
+                    If Len(dir$(source_path & "tables\" & td.name & ".txt")) > 0 Then
+                        obj_data_count = obj_data_count + 1
+                    End If
+                ElseIf (Len(Replace(include_tables, " ", vbNullString)) > 0) And include_tables <> "*" Then
+                    DoEvents
+                    On Error GoTo Err_TableNotFound
+                    If InCollection(IncludeTablesCol, td.name) Then
+                        VCS_Table.ExportTableData CStr(td.name), source_path & "tables\"
+                        obj_data_count = obj_data_count + 1
+                    End If
+Err_TableNotFound:
+                    
+                'else don't export table data
+                End If
+            Else
+                VCS_Table.ExportLinkedTable td.name, obj_path
+            End If
+            
+            obj_count = obj_count + 1
+            
+            Call SysCmd(4, "Export table definition: " & obj_count & " on " & tds.count)
+            
+        End If
+
+next_td:
+    Next
+    
+    Debug.Print "[" & obj_count & "]"
+    If obj_data_count > 0 Then
+      Debug.Print VCS_String.PadRight("Exported data...", 24) & "[" & obj_data_count & "]"
+    End If
+
+    Call SysCmd(4, "Export relations")
+    Debug.Print VCS_String.PadRight("Exporting Relations...", 24);
+    
+    obj_count = 0
+    obj_path = source_path & "relations\"
+    VCS_Dir.MkDirIfNotExist Left$(obj_path, InStrRev(obj_path, "\"))
+
+    VCS_Dir.ClearTextFilesFromDir obj_path, "txt"
+
+    Dim aRelation As DAO.Relation
+    
+    For Each aRelation In CurrentDb.Relations
+        ' Exclude relations from system tables and inherited (linked) relations
+        If Not (aRelation.name = "MSysNavPaneGroupsMSysNavPaneGroupToObjects" _
+                Or aRelation.name = "MSysNavPaneGroupCategoriesMSysNavPaneGroups" _
+                Or (aRelation.Attributes And DAO.RelationAttributeEnum.dbRelationInherited) = _
+                DAO.RelationAttributeEnum.dbRelationInherited) Then
+            VCS_Relation.ExportRelation aRelation, obj_path & aRelation.name & ".txt"
+            obj_count = obj_count + 1
+        End If
+    Next
+    Debug.Print "[" & obj_count & "]"
+    
+    Debug.Print "Done."
+End Sub
+
+
+' Main entry point for IMPORT. Import all forms, reports, queries,
+' macros, modules, and lookup tables from `source` folder under the
+' database's folder.
+Public Sub ImportAllSource()
+    Dim fso As Object
+    Dim source_path As String
+    Dim obj_path As String
+    Dim obj_type As Variant
+    Dim obj_type_split() As String
+    Dim obj_type_label As String
+    Dim obj_type_num As Integer
+    Dim obj_count As Integer
+    Dim fileName As String
+    Dim obj_name As String
+    Dim ucs2 As Boolean
+
+    Set fso = CreateObject("Scripting.FileSystemObject")
+
+    SysCmd acSysCmdInitMeter, "Importing: ", 11
+    Dim counter As Integer
+    counter = 0
+    SysCmd acSysCmdUpdateMeter, counter
+
+    CloseFormsReports
+    'InitUsingUcs2
+
+    source_path = VCS_Dir.ProjectPath() & "source\"
+    If Not fso.FolderExists(source_path) Then
+        MsgBox "No source found at:" & vbCrLf & source_path, vbExclamation, "Import failed"
+        Exit Sub
+    End If
+
+    Debug.Print
+    
+    If Not VCS_Reference.ImportReferences(source_path) Then
+        Debug.Print "Info: no references file in " & source_path
+        Debug.Print
+    End If
+
+    obj_path = source_path & "queries\"
+    fileName = dir$(obj_path & "*.bas")
+    
+    Dim tempFilePath As String
+    tempFilePath = VCS_File.TempFile()
+    
+    If Len(fileName) > 0 Then
+        Debug.Print VCS_String.PadRight("Importing queries...", 24);
+        obj_count = 0
+        Do Until Len(fileName) = 0
+            DoEvents
+            obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+            VCS_IE_Functions.ImportObject acQuery, obj_name, obj_path & fileName, VCS_File.UsingUcs2
+            VCS_IE_Functions.ExportObject acQuery, obj_name, tempFilePath, VCS_File.UsingUcs2
+            VCS_IE_Functions.ImportObject acQuery, obj_name, tempFilePath, VCS_File.UsingUcs2
+            obj_count = obj_count + 1
+            fileName = dir$()
+        Loop
+        Debug.Print "[" & obj_count & "]"
+    End If
+
+    counter = counter + 1
+    SysCmd acSysCmdUpdateMeter, counter
+    
+    VCS_Dir.DelIfExist tempFilePath
+
+    ' restore table definitions
+    obj_path = source_path & "tbldef\"
+    fileName = dir$(obj_path & "*.sql")
+    If Len(fileName) > 0 Then
+        Debug.Print VCS_String.PadRight("Importing tabledefs...", 24);
+        obj_count = 0
+        Do Until Len(fileName) = 0
+            obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+            If DebugOutput Then
+                If obj_count = 0 Then
+                    Debug.Print
+                End If
+                Debug.Print "  [debug] table " & obj_name;
+                Debug.Print
+            End If
+            VCS_Table.ImportTableDef CStr(obj_name), obj_path
+            obj_count = obj_count + 1
+            fileName = dir$()
+        Loop
+        Debug.Print "[" & obj_count & "]"
+    End If
+    
+    counter = counter + 1
+    SysCmd acSysCmdUpdateMeter, counter
+    
+    ' restore linked tables - we must have access to the remote store to import these!
+    fileName = dir$(obj_path & "*.LNKD")
+    If Len(fileName) > 0 Then
+        Debug.Print VCS_String.PadRight("Importing Linked tabledefs...", 24);
+        obj_count = 0
+        Do Until Len(fileName) = 0
+            obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+            If DebugOutput Then
+                If obj_count = 0 Then
+                    Debug.Print
+                End If
+                Debug.Print "  [debug] table " & obj_name;
+                Debug.Print
+            End If
+            VCS_Table.ImportLinkedTable CStr(obj_name), obj_path
+            obj_count = obj_count + 1
+            fileName = dir$()
+        Loop
+        Debug.Print "[" & obj_count & "]"
+    End If
+    
+    counter = counter + 1
+    SysCmd acSysCmdUpdateMeter, counter
+    
+    ' NOW we may load data
+    obj_path = source_path & "tables\"
+    fileName = dir$(obj_path & "*.txt")
+    If Len(fileName) > 0 Then
+        Debug.Print VCS_String.PadRight("Importing tables...", 24);
+        obj_count = 0
+        Do Until Len(fileName) = 0
+            DoEvents
+            obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+            VCS_Table.ImportTableData CStr(obj_name), obj_path
+            obj_count = obj_count + 1
+            fileName = dir$()
+        Loop
+        Debug.Print "[" & obj_count & "]"
+    End If
+
+    counter = counter + 1
+    SysCmd acSysCmdUpdateMeter, counter
+    
+    'load Data Macros - not DRY!
+    obj_path = source_path & "tbldef\"
+    fileName = dir$(obj_path & "*.xml")
+    If Len(fileName) > 0 Then
+        Debug.Print VCS_String.PadRight("Importing Data Macros...", 24);
+        obj_count = 0
+        Do Until Len(fileName) = 0
+            DoEvents
+            obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+            'VCS_Table.ImportTableData CStr(obj_name), obj_path
+            VCS_DataMacro.ImportDataMacros obj_name, obj_path
+            obj_count = obj_count + 1
+            fileName = dir$()
+        Loop
+        Debug.Print "[" & obj_count & "]"
+    End If
+    
+    counter = counter + 1
+    SysCmd acSysCmdUpdateMeter, counter
+
+        'import Data Macros
+    
+
+    For Each obj_type In Split( _
+        "forms|" & acForm & "," & _
+        "reports|" & acReport & "," & _
+        "macros|" & acMacro & "," & _
+        "modules|" & acModule _
+        , "," _
+    )
+        obj_type_split = Split(obj_type, "|")
+        obj_type_label = obj_type_split(0)
+        obj_type_num = val(obj_type_split(1))
+        obj_path = source_path & obj_type_label & "\"
+         
+            
+        fileName = dir$(obj_path & "*.bas")
+        If Len(fileName) > 0 Then
+            Debug.Print VCS_String.PadRight("Importing " & obj_type_label & "...", 24);
+            obj_count = 0
+            Do Until Len(fileName) = 0
+                ' DoEvents no good idea!
+                obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+                If obj_type_label = "modules" Then
+                    ucs2 = False
+                Else
+                    ucs2 = VCS_File.UsingUcs2
+                End If
+                If IsNotVCS(obj_name) Then
+                    VCS_IE_Functions.ImportObject obj_type_num, obj_name, obj_path & fileName, ucs2
+                    obj_count = obj_count + 1
+                Else
+                    If ArchiveMyself Then
+                            MsgBox "Module " & obj_name & " could not be updated while running. Ensure latest version is included!", vbExclamation, "Warning"
+                    End If
+                End If
+                fileName = dir$()
+            Loop
+            Debug.Print "[" & obj_count & "]"
+        
+        End If
+        
+        counter = counter + 1
+        SysCmd acSysCmdUpdateMeter, counter
+    
+    Next
+    
+    'import Print Variables
+    Debug.Print VCS_String.PadRight("Importing Print Vars...", 24);
+    obj_count = 0
+    
+    obj_path = source_path & "reports\"
+    fileName = dir$(obj_path & "*.pv")
+    Do Until Len(fileName) = 0
+        DoEvents
+        obj_name = Mid$(fileName, 1, InStrRev(fileName, ".") - 1)
+        VCS_Report.ImportPrintVars obj_name, obj_path & fileName
+        obj_count = obj_count + 1
+        fileName = dir$()
+    Loop
+    Debug.Print "[" & obj_count & "]"
+    
+    'import relations
+    Debug.Print VCS_String.PadRight("Importing Relations...", 24);
+    obj_count = 0
+    obj_path = source_path & "relations\"
+    fileName = dir$(obj_path & "*.txt")
+    Do Until Len(fileName) = 0
+        DoEvents
+        VCS_Relation.ImportRelation obj_path & fileName
+        obj_count = obj_count + 1
+        fileName = dir$()
+    Loop
+    Debug.Print "[" & obj_count & "]"
+    DoEvents
+    
+    SysCmd acSysCmdRemoveMeter
+    
+    Debug.Print "Done."
+End Sub
+
+' Main entry point for ImportProject.
+' Drop all forms, reports, queries, macros, modules.
+' execute ImportAllSource.
+Public Sub ImportProject()
+On Error GoTo errorHandler
+
+    If MsgBox("This action will delete all existing: " & vbCrLf & _
+              vbCrLf & _
+              Chr$(149) & " Tables" & vbCrLf & _
+              Chr$(149) & " Forms" & vbCrLf & _
+              Chr$(149) & " Macros" & vbCrLf & _
+              Chr$(149) & " Modules" & vbCrLf & _
+              Chr$(149) & " Queries" & vbCrLf & _
+              Chr$(149) & " Reports" & vbCrLf & _
+              vbCrLf & _
+              "Are you sure you want to proceed?", vbCritical + vbYesNo, _
+              "Import Project") <> vbYes Then
+        Exit Sub
+    End If
+
+    Dim Db As DAO.Database
+    Set Db = CurrentDb
+    CloseFormsReports
+
+    Debug.Print
+    Debug.Print "Deleting Existing Objects"
+    Debug.Print
+    
+    Dim rel As DAO.Relation
+    For Each rel In CurrentDb.Relations
+        If Not (rel.name = "MSysNavPaneGroupsMSysNavPaneGroupToObjects" Or _
+                rel.name = "MSysNavPaneGroupCategoriesMSysNavPaneGroups") Then
+            CurrentDb.Relations.Delete (rel.name)
+        End If
+    Next
+
+    Dim dbObject As Object
+    For Each dbObject In Db.QueryDefs
+        DoEvents
+        If Left$(dbObject.name, 1) <> "~" Then
+'            Debug.Print dbObject.Name
+            Db.QueryDefs.Delete dbObject.name
+        End If
+    Next
+    
+    Dim td As DAO.TableDef
+    For Each td In CurrentDb.TableDefs
+        If Left$(td.name, 4) <> "MSys" And _
+            Left$(td.name, 1) <> "~" Then
+            CurrentDb.TableDefs.Delete (td.name)
+        End If
+    Next
+
+    Dim objType As Variant
+    Dim objTypeArray() As String
+    Dim doc As Object
+    '
+    '  Object Type Constants
+    Const OTNAME As Byte = 0
+    Const OTID As Byte = 1
+
+    For Each objType In Split( _
+            "Forms|" & acForm & "," & _
+            "Reports|" & acReport & "," & _
+            "Scripts|" & acMacro & "," & _
+            "Modules|" & acModule _
+            , "," _
+        )
+        objTypeArray = Split(objType, "|")
+        DoEvents
+        For Each doc In Db.Containers(objTypeArray(OTNAME)).Documents
+            DoEvents
+            If (Left$(doc.name, 1) <> "~") And _
+               (IsNotVCS(doc.name)) Then
+'                Debug.Print doc.Name
+                DoCmd.DeleteObject objTypeArray(OTID), doc.name
+            End If
+        Next
+    Next
+    
+    Debug.Print "================="
+    Debug.Print "Importing Project"
+    ImportAllSource
+    
+    Exit Sub
+
+errorHandler:
+    Debug.Print "VCS_ImportExport.ImportProject: Error #" & err.number & vbCrLf & _
+                err.Description
+End Sub
+
+' Expose for use as function, can be called by query
+Public Sub make()
+    ImportProject
+End Sub
+
+
+
+'===================================================================================================================================
+'-----------------------------------------------------------'
+' Helper Functions - these should be put in their own files '
+'-----------------------------------------------------------'
+
+' Close all open forms.
+Private Sub CloseFormsReports()
+    On Error GoTo errorHandler
+    Do While Forms.count > 0
+        DoCmd.Close acForm, Forms(0).name
+        DoEvents
+    Loop
+    Do While Reports.count > 0
+        DoCmd.Close acReport, Reports(0).name
+        DoEvents
+    Loop
+    Exit Sub
+
+errorHandler:
+    Debug.Print "VCS_ImportExport.CloseFormsReports: Error #" & err.number & vbCrLf & _
+                err.Description
+End Sub
+
+
+'errno 457 - duplicate key (& item)
+Public Function StrSetToCol(ByVal strSet As String, ByVal delimiter As String) As Collection 'throws errors
+    Dim strSetArray() As String
+    Dim col As Collection
+    
+    Set col = New Collection
+    strSetArray = Split(strSet, delimiter)
+    
+    Dim item As Variant
+    For Each item In strSetArray
+        col.Add item, item
+    Next
+    
+    Set StrSetToCol = col
+End Function
+
+
+' Check if an item or key is in a collection
+Public Function InCollection(col As Collection, Optional vItem, Optional vKey) As Boolean
+    On Error Resume Next
+
+    Dim vColItem As Variant
+
+    InCollection = False
+
+    If Not IsMissing(vKey) Then
+        col.item vKey
+
+        '5 if not in collection, it is 91 if no collection exists
+        If err.number <> 5 And err.number <> 91 Then
+            InCollection = True
+        End If
+    ElseIf Not IsMissing(vItem) Then
+        For Each vColItem In col
+            If vColItem = vItem Then
+                InCollection = True
+                GoTo Exit_Proc
+            End If
+        Next vColItem
+    End If
+
+Exit_Proc:
+    Exit Function
+Err_Handle:
+    Resume Exit_Proc
+End Function

source/modules/VCS_Loader.bas

@@ -0,0 +1,74 @@
+Option Compare Database
+
+Option Explicit
+
+Public Sub loadVCS(Optional ByVal SourceDirectory As String)
+    If SourceDirectory = vbNullString Then
+      SourceDirectory = CurrentProject.Path & "\MSAccess-VCS\"
+    End If
+
+'check if directory exists! - SourceDirectory could be a file or not exist
+On Error GoTo Err_DirCheck
+    If ((GetAttr(SourceDirectory) And vbDirectory) = vbDirectory) Then
+        GoTo Fin_DirCheck
+    Else
+        'SourceDirectory is not a directory
+        err.Raise 60000, "loadVCS", "Source Directory specified is not a directory"
+    End If
+
+Err_DirCheck:
+    
+    If err.number = 53 Then 'SourceDirectory does not exist
+        Debug.Print err.number & " | " & "File/Directory not found"
+    Else
+        Debug.Print err.number & " | " & err.Description
+    End If
+    Exit Sub
+Fin_DirCheck:
+
+    'delete if modules already exist + provide warning of deletion?
+
+    On Error GoTo Err_DelHandler
+
+    Dim fileName As String
+    'Use the list of files to import as the list to delete
+    fileName = dir$(SourceDirectory & "*.bas")
+    Do Until Len(fileName) = 0
+        'strip file type from file name
+        fileName = Left$(fileName, InStrRev(fileName, ".bas") - 1)
+        DoCmd.DeleteObject acModule, fileName
+        fileName = dir$()
+    Loop
+
+    GoTo Fin_DelHandler
+    
+Err_DelHandler:
+    If err.number <> 7874 Then 'is not - can't find object
+        Debug.Print "WARNING (" & err.number & ") | " & err.Description
+    End If
+    Resume Next
+    
+Fin_DelHandler:
+    fileName = vbNullString
+
+'import files from specific dir? or allow user to input their own dir?
+On Error GoTo Err_LoadHandler
+
+    fileName = dir$(SourceDirectory & "*.bas")
+    Do Until Len(fileName) = 0
+        'strip file type from file name
+        fileName = Left$(fileName, InStrRev(fileName, ".bas") - 1)
+        Application.LoadFromText acModule, fileName, SourceDirectory & fileName & ".bas"
+        fileName = dir$()
+    Loop
+
+    GoTo Fin_LoadHandler
+    
+Err_LoadHandler:
+    Debug.Print err.number & " | " & err.Description
+    Resume Next
+
+Fin_LoadHandler:
+    Debug.Print "Done"
+
+End Sub

source/modules/VCS_Reference.bas

@@ -0,0 +1,82 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+
+' Import References from a CSV, true=SUCCESS
+Public Function ImportReferences(ByVal obj_path As String) As Boolean
+    Dim fso As Object
+    Dim InFile As Object
+    Dim line As String
+    Dim item() As String
+    Dim GUID As String
+    Dim Major As Long
+    Dim Minor As Long
+    Dim fileName As String
+    Dim refName As String
+    
+    fileName = dir$(obj_path & "references.csv")
+    If Len(fileName) = 0 Then
+        ImportReferences = False
+        Exit Function
+    End If
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    Set InFile = fso.OpenTextFile(obj_path & fileName, iomode:=ForReading, create:=False, Format:=TristateFalse)
+    
+On Error GoTo failed_guid
+    Do Until InFile.AtEndOfStream
+        line = InFile.readline
+        item = Split(line, ",")
+        If UBound(item) = 2 Then 'a ref with a guid
+          GUID = Trim$(item(0))
+          Major = CLng(item(1))
+          Minor = CLng(item(2))
+          Application.References.AddFromGuid GUID, Major, Minor
+        Else
+          refName = Trim$(item(0))
+          Application.References.AddFromFile refName
+        End If
+go_on:
+    Loop
+On Error GoTo 0
+    InFile.Close
+    Set InFile = Nothing
+    Set fso = Nothing
+    ImportReferences = True
+    Exit Function
+    
+failed_guid:
+    If err.number = 32813 Then
+        'The reference is already present in the access project - so we can ignore the error
+        Resume Next
+    Else
+        MsgBox "Failed to register " & GUID, , "Error: " & err.number
+        'Do we really want to carry on the import with missing references??? - Surely this is fatal
+        Resume go_on
+    End If
+    
+End Function
+
+' Export References to a CSV
+Public Sub ExportReferences(ByVal obj_path As String)
+    Dim fso As Object
+    Dim OutFile As Object
+    Dim line As String
+    Dim ref As Reference
+
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    Set OutFile = fso.CreateTextFile(obj_path & "references.csv", overwrite:=True, Unicode:=False)
+    For Each ref In Application.References
+        If ref.GUID <> vbNullString Then ' references of types mdb,accdb,mde etc don't have a GUID
+            If Not ref.BuiltIn Then
+                line = ref.GUID & "," & CStr(ref.Major) & "," & CStr(ref.Minor)
+                OutFile.WriteLine line
+            End If
+        Else
+            line = ref.FullPath
+            OutFile.WriteLine line
+        End If
+    Next
+    OutFile.Close
+End Sub

source/modules/VCS_Relation.bas

@@ -0,0 +1,61 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+
+Public Sub ExportRelation(ByVal rel As DAO.Relation, ByVal filePath As String)
+    Dim fso As Object
+    Dim OutFile As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    Set OutFile = fso.CreateTextFile(filePath, overwrite:=True, Unicode:=False)
+
+    OutFile.WriteLine rel.Attributes 'RelationAttributeEnum
+    OutFile.WriteLine rel.name
+    OutFile.WriteLine rel.table
+    OutFile.WriteLine rel.foreignTable
+    
+    Dim f As DAO.Field
+    For Each f In rel.Fields
+        OutFile.WriteLine "Field = Begin"
+        OutFile.WriteLine f.name
+        OutFile.WriteLine f.ForeignName
+        OutFile.WriteLine "End"
+    Next
+    
+    OutFile.Close
+
+End Sub
+
+Public Sub ImportRelation(ByVal filePath As String)
+    Dim fso As Object
+    Dim InFile As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    Set InFile = fso.OpenTextFile(filePath, iomode:=ForReading, create:=False, Format:=TristateFalse)
+    Dim rel As DAO.Relation
+    Set rel = New DAO.Relation
+    
+    rel.Attributes = InFile.readline
+    rel.name = InFile.readline
+    rel.table = InFile.readline
+    rel.foreignTable = InFile.readline
+    
+    Dim f As DAO.Field
+    Do Until InFile.AtEndOfStream
+        If "Field = Begin" = InFile.readline Then
+            Set f = New DAO.Field
+            f.name = InFile.readline
+            f.ForeignName = InFile.readline
+            If "End" <> InFile.readline Then
+                Set f = Nothing
+                err.Raise 40000, "ImportRelation", "Missing 'End' for a 'Begin' in " & filePath
+            End If
+            rel.Fields.Append f
+        End If
+    Loop
+    
+    InFile.Close
+    
+    CurrentDb.Relations.Append rel
+
+End Sub

source/modules/VCS_Report.bas

@@ -0,0 +1,139 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+' --------------------------------
+' Structures
+' --------------------------------
+
+Private Type str_DEVMODE
+  RGB As String * 94
+End Type
+
+Private Type type_DEVMODE
+  strDeviceName(31) As Byte 'vba strings are encoded in unicode (16 bit) not ascii
+  intSpecVersion As Integer
+  intDriverVersion As Integer
+  intSize As Integer
+  intDriverExtra As Integer
+  lngFields As Long
+  intOrientation As Integer
+  intPaperSize As Integer
+  intPaperLength As Integer
+  intPaperWidth As Integer
+  intScale As Integer
+  intCopies As Integer
+  intDefaultSource As Integer
+  intPrintQuality As Integer
+  intColor As Integer
+  intDuplex As Integer
+  intResolution As Integer
+  intTTOption As Integer
+  intCollate As Integer
+  strFormName(31) As Byte
+  lngPad As Long
+  lngBits As Long
+  lngPW As Long
+  lngPH As Long
+  lngDFI As Long
+  lngDFr As Long
+End Type
+
+
+'Exports print vars for reports
+Public Sub ExportPrintVars(ByVal obj_name As String, ByVal filePath As String)
+  DoEvents
+  Dim fso As Object
+  Set fso = CreateObject("Scripting.FileSystemObject")
+  
+  Dim DevModeString As str_DEVMODE
+  Dim DevModeExtra As String
+  Dim DM As type_DEVMODE
+  Dim rpt As Report
+  
+  'report must be open to access Report object
+  'report must be opened in design view to save changes to the print vars
+   DoCmd.SetWarnings False
+   DoCmd.OpenReport obj_name, acViewDesign, , , acHidden
+   DoCmd.SetWarnings True
+   Set rpt = Reports(obj_name)
+  
+  
+  'read print vars into struct
+  If Not IsNull(rpt.PrtDevMode) Then
+    DevModeExtra = rpt.PrtDevMode
+    DevModeString.RGB = DevModeExtra
+    LSet DM = DevModeString
+  Else
+    Set rpt = Nothing
+    DoCmd.Close acReport, obj_name, acSaveNo
+    Debug.Print "Warning: PrtDevMode is null"
+    Exit Sub
+  End If
+  
+  Dim OutFile As Object
+  Set OutFile = fso.CreateTextFile(filePath, overwrite:=True, Unicode:=False)
+  
+  'print out print var values
+  OutFile.WriteLine DM.intOrientation
+  OutFile.WriteLine DM.intPaperSize
+  OutFile.WriteLine DM.intPaperLength
+  OutFile.WriteLine DM.intPaperWidth
+  OutFile.WriteLine DM.intScale
+  OutFile.Close
+  
+  Set rpt = Nothing
+  
+  DoCmd.Close acReport, obj_name, acSaveYes
+End Sub
+
+Public Sub ImportPrintVars(ByVal obj_name As String, ByVal filePath As String)
+  
+  Dim fso As Object
+  Set fso = CreateObject("Scripting.FileSystemObject")
+  
+  Dim DevModeString As str_DEVMODE
+  Dim DevModeExtra As String
+  
+  Dim DM As type_DEVMODE
+  Dim rpt As Report
+  'report must be open to access Report object
+  'report must be opened in design view to save changes to the print vars
+  
+  DoCmd.OpenReport obj_name, acViewDesign
+  
+  Set rpt = Reports(obj_name)
+  
+  'read print vars into struct
+  If Not IsNull(rpt.PrtDevMode) Then
+    DevModeExtra = rpt.PrtDevMode
+    DevModeString.RGB = DevModeExtra
+    LSet DM = DevModeString
+  Else
+    Set rpt = Nothing
+    DoCmd.Close acReport, obj_name, acSaveNo
+    Debug.Print "Warning: PrtDevMode is null"
+    Exit Sub
+  End If
+  
+  Dim InFile As Object
+  Set InFile = fso.OpenTextFile(filePath, iomode:=ForReading, create:=False, Format:=TristateFalse)
+  
+  'print out print var values
+  DM.intOrientation = InFile.readline
+  DM.intPaperSize = InFile.readline
+  DM.intPaperLength = InFile.readline
+  DM.intPaperWidth = InFile.readline
+  DM.intScale = InFile.readline
+  InFile.Close
+   
+  'write print vars back into report
+  LSet DevModeString = DM
+  Mid(DevModeExtra, 1, 94) = DevModeString.RGB
+  rpt.PrtDevMode = DevModeExtra
+  
+  Set rpt = Nothing
+  
+  DoCmd.Close acReport, obj_name, acSaveYes
+End Sub

source/modules/VCS_String.bas

@@ -0,0 +1,82 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+
+'--------------------
+' String Functions: String Builder,String Padding (right only), Substrings
+'--------------------
+
+' String builder: Init
+Public Function Sb_Init() As String()
+    Dim x(-1 To -1) As String
+    Sb_Init = x
+End Function
+
+' String builder: Clear
+Public Sub Sb_Clear(ByRef sb() As String)
+    ReDim Sb_Init(-1 To -1)
+End Sub
+
+' String builder: Append
+Public Sub Sb_Append(ByRef sb() As String, ByVal value As String)
+    If LBound(sb) = -1 Then
+        ReDim sb(0 To 0)
+    Else
+        ReDim Preserve sb(0 To UBound(sb) + 1)
+    End If
+    sb(UBound(sb)) = value
+End Sub
+
+' String builder: Get value
+Public Function Sb_Get(ByRef sb() As String) As String
+    Sb_Get = Join(sb, "")
+End Function
+
+
+' Pad a string on the right to make it `count` characters long.
+Public Function PadRight(ByVal value As String, ByVal count As Integer) As String
+    PadRight = value
+    If Len(value) < count Then
+        PadRight = PadRight & Space$(count - Len(value))
+    End If
+End Function
+
+' returns substring between e.g. "(" and ")", internal brackets ar skippped
+Public Function SubString(ByVal p As Integer, ByVal s As String, ByVal startsWith As String, _
+                          ByVal endsWith As String) As String
+    Dim start As Integer
+    Dim cursor As Integer
+    Dim p1 As Integer
+    Dim p2 As Integer
+    Dim level As Integer
+    
+    start = InStr(p, s, startsWith)
+    level = 1
+    p1 = InStr(start + 1, s, startsWith)
+    p2 = InStr(start + 1, s, endsWith)
+    
+    Do While level > 0
+        If p1 > p2 And p2 > 0 Then
+            cursor = p2
+            level = level - 1
+        ElseIf p2 > p1 And p1 > 0 Then
+            cursor = p1
+            level = level + 1
+        ElseIf p2 > 0 And p1 = 0 Then
+            cursor = p2
+            level = level - 1
+        ElseIf p1 > 0 And p1 = 0 Then
+            cursor = p1
+            level = level + 1
+        ElseIf p1 = 0 And p2 = 0 Then
+            SubString = vbNullString
+            Exit Function
+        End If
+        p1 = InStr(cursor + 1, s, startsWith)
+        p2 = InStr(cursor + 1, s, endsWith)
+    Loop
+    
+    SubString = Mid$(s, start + 1, cursor - start - 1)
+End Function

source/modules/VCS_Table.bas

@@ -0,0 +1,630 @@
+Option Compare Database
+
+Option Private Module
+Option Explicit
+
+' --------------------------------
+' Structures
+' --------------------------------
+
+' Structure to keep track of "on Update" and "on Delete" clauses
+' Access does not in all cases execute such queries
+Private Type structEnforce
+    foreignTable As String
+    foreignFields() As String
+    table As String
+    refFields() As String
+    isUpdate As Boolean
+End Type
+
+' keeping "on Update" relations to be complemented after table creation
+Private K() As structEnforce
+
+
+Public Sub ExportLinkedTable(ByVal tbl_name As String, ByVal obj_path As String)
+    On Error GoTo Err_LinkedTable
+    
+    Dim tempFilePath As String
+    
+    tempFilePath = VCS_File.TempFile()
+    
+    Dim fso As Object
+    Dim OutFile As Object
+
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    ' open file for writing with Create=True, Unicode=True (USC-2 Little Endian format)
+    VCS_Dir.MkDirIfNotExist obj_path
+    
+    Set OutFile = fso.CreateTextFile(tempFilePath, overwrite:=True, Unicode:=True)
+    
+    OutFile.Write CurrentDb.TableDefs(tbl_name).name
+    OutFile.Write vbCrLf
+    
+    If InStr(1, CurrentDb.TableDefs(tbl_name).connect, "DATABASE=" & CurrentProject.Path) Then
+        'change to relatave path
+        Dim connect() As String
+        connect = Split(CurrentDb.TableDefs(tbl_name).connect, CurrentProject.Path)
+        OutFile.Write connect(0) & "." & connect(1)
+    Else
+        OutFile.Write CurrentDb.TableDefs(tbl_name).connect
+    End If
+    
+    OutFile.Write vbCrLf
+    OutFile.Write CurrentDb.TableDefs(tbl_name).SourceTableName
+    OutFile.Write vbCrLf
+    
+    Dim Db As DAO.Database
+    Set Db = CurrentDb
+    Dim td As DAO.TableDef
+    Set td = Db.TableDefs(tbl_name)
+    Dim idx As DAO.Index
+    
+    For Each idx In td.Indexes
+        If idx.Primary Then
+            OutFile.Write Right$(idx.Fields, Len(idx.Fields) - 1)
+            OutFile.Write vbCrLf
+        End If
+
+    Next
+    
+Err_LinkedTable_Fin:
+    On Error Resume Next
+    OutFile.Close
+    'save files as .odbc
+    VCS_File.ConvertUcs2Utf8 tempFilePath, obj_path & tbl_name & ".LNKD"
+    
+    Exit Sub
+    
+Err_LinkedTable:
+    OutFile.Close
+    MsgBox err.Description, vbCritical, "ERROR: EXPORT LINKED TABLE"
+    Resume Err_LinkedTable_Fin
+End Sub
+
+' This requires Microsoft ADO Ext. 2.x for DLL and Security
+' See reference: https://social.msdn.microsoft.com/Forums/office/en-US/883087ba-2c25-4571-bd3c-706061466a11/how-can-i-programmatically-access-scale-property-of-a-decimal-data-type-field?forum=accessdev
+Private Function formatDecimal(ByVal tableName As String, ByVal fieldName As String) As String
+
+    Dim cnn As ADODB.Connection
+    Dim cat As ADOX.Catalog
+    Dim col As ADOX.Column
+    
+    Set cnn = New ADODB.Connection
+    Set cat = New ADOX.Catalog
+    
+
+    Set cnn = CurrentProject.Connection
+    Set cat.ActiveConnection = cnn
+
+    Set col = cat.Tables(tableName).Columns(fieldName)
+
+    formatDecimal = "(" & col.Precision & ", " & col.NumericScale & ")"
+
+    Set col = Nothing
+    Set cat = Nothing
+    Set cnn = Nothing
+
+End Function
+
+' Save a Table Definition as SQL statement
+Public Sub ExportTableDef(Db As DAO.Database, td As DAO.TableDef, ByVal tableName As String, _
+                          ByVal directory As String)
+    Dim fileName As String
+    fileName = directory & tableName & ".sql"
+    Dim sql As String
+    Dim fieldAttributeSql As String
+    Dim idx As DAO.Index
+    Dim fi As DAO.Field
+    Dim fso As Object
+    Dim OutFile As Object
+    Dim ff As Object
+    'Debug.Print tableName
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    Set OutFile = fso.CreateTextFile(fileName, overwrite:=True, Unicode:=False)
+    sql = "CREATE TABLE " & strName(tableName) & " (" & vbCrLf
+    For Each fi In td.Fields
+        sql = sql & "  " & strName(fi.name) & " "
+        If (fi.Attributes And dbAutoIncrField) Then
+            sql = sql & "AUTOINCREMENT"
+        Else
+            sql = sql & strType(fi.Type) & " "
+        End If
+        Select Case fi.Type
+            Case dbText, dbVarBinary
+                sql = sql & "(" & fi.Size & ")"
+            Case dbDecimal
+                sql = sql & formatDecimal(tableName, fi.name)
+            Case Else
+        End Select
+        For Each idx In td.Indexes
+            fieldAttributeSql = vbNullString
+            If idx.Fields.count = 1 And idx.Fields(0).name = fi.name Then
+                If idx.Primary Then fieldAttributeSql = fieldAttributeSql & " PRIMARY KEY "
+                If idx.Unique Then fieldAttributeSql = fieldAttributeSql & " UNIQUE "
+                If idx.Required Then fieldAttributeSql = fieldAttributeSql & " NOT NULL "
+                If idx.Foreign Then
+                    Set ff = idx.Fields
+                    fieldAttributeSql = fieldAttributeSql & formatReferences(Db, ff, tableName)
+                End If
+                If Len(fieldAttributeSql) > 0 Then fieldAttributeSql = " CONSTRAINT " & strName(idx.name) & fieldAttributeSql
+            End If
+            sql = sql & fieldAttributeSql
+        Next
+        sql = sql & "," & vbCrLf
+    Next
+    sql = Left$(sql, Len(sql) - 3) ' strip off last comma and crlf
+    
+    Dim constraintSql As String
+    For Each idx In td.Indexes
+        If idx.Fields.count > 1 Then
+            If Len(constraintSql) = 0 Then constraintSql = constraintSql & " CONSTRAINT "
+            If idx.Primary Then constraintSql = constraintSql & formatConstraint("PRIMARY KEY", idx)
+            If Not idx.Foreign Then
+                If Len(constraintSql) > 0 Then
+                    sql = sql & "," & vbCrLf & "  " & constraintSql
+                    sql = sql & formatReferences(Db, idx.Fields, tableName)
+                End If
+            End If
+        End If
+    Next
+    sql = sql & vbCrLf & ")"
+
+    'Debug.Print sql
+    OutFile.WriteLine sql
+    
+    OutFile.Close
+    
+    'exort Data Macros
+    VCS_DataMacro.ExportDataMacros tableName, directory
+    
+End Sub
+
+Private Function formatReferences(Db As DAO.Database, ff As Object, _
+                                  ByVal tableName As String) As String
+
+    Dim rel As DAO.Relation
+    Dim sql As String
+    Dim f As DAO.Field
+    
+    For Each rel In Db.Relations
+        If (rel.foreignTable = tableName) Then
+         If FieldsIdentical(ff, rel.Fields) Then
+          sql = " REFERENCES "
+          sql = sql & strName(rel.table) & " ("
+          For Each f In rel.Fields
+            sql = sql & strName(f.name) & ","
+          Next
+          sql = Left$(sql, Len(sql) - 1) & ")"
+          If rel.Attributes And dbRelationUpdateCascade Then
+            sql = sql + " ON UPDATE CASCADE "
+          End If
+          If rel.Attributes And dbRelationDeleteCascade Then
+            sql = sql + " ON DELETE CASCADE "
+          End If
+          Exit For
+         End If
+        End If
+    Next
+    
+    formatReferences = sql
+End Function
+
+Private Function formatConstraint(ByVal keyw As String, ByVal idx As DAO.Index) As String
+    Dim sql As String
+    Dim fi As DAO.Field
+    
+    sql = strName(idx.name) & " " & keyw & " ("
+    For Each fi In idx.Fields
+        sql = sql & strName(fi.name) & ", "
+    Next
+    sql = Left$(sql, Len(sql) - 2) & ")" 'strip off last comma and close brackets
+    
+    'return value
+    formatConstraint = sql
+End Function
+
+Private Function strName(ByVal s As String) As String
+    strName = "[" & s & "]"
+End Function
+
+Private Function strType(ByVal i As Integer) As String
+    Select Case i
+    Case dbLongBinary
+        strType = "LONGBINARY"
+    Case dbBinary
+        strType = "BINARY"
+    Case dbBoolean
+        strType = "BIT"
+    Case dbAutoIncrField
+        strType = "COUNTER"
+    Case dbCurrency
+        strType = "CURRENCY"
+    Case dbDate, dbTime
+        strType = "DATETIME"
+    Case dbGUID
+        strType = "GUID"
+    Case dbMemo
+        strType = "LONGTEXT"
+    Case dbDouble
+        strType = "DOUBLE"
+    Case dbSingle
+        strType = "SINGLE"
+    Case dbByte
+        strType = "BYTE"
+    Case dbInteger
+        strType = "SHORT"
+    Case dbLong
+        strType = "LONG"
+    Case dbNumeric
+        strType = "NUMERIC"
+    Case dbText
+        strType = "VARCHAR"
+    Case dbDecimal
+        strType = "DECIMAL"
+    Case Else
+        strType = "VARCHAR"
+    End Select
+End Function
+
+Private Function FieldsIdentical(ff As Object, gg As Object) As Boolean
+    Dim f As DAO.Field
+    If ff.count <> gg.count Then
+        FieldsIdentical = False
+        Exit Function
+    End If
+    For Each f In ff
+        If Not FieldInFields(f, gg) Then
+        FieldsIdentical = False
+        Exit Function
+        End If
+    Next
+    
+    FieldsIdentical = True
+End Function
+
+Private Function FieldInFields(fi As DAO.Field, ff As DAO.Fields) As Boolean
+    Dim f As DAO.Field
+    For Each f In ff
+        If f.name = fi.name Then
+            FieldInFields = True
+            Exit Function
+        End If
+    Next
+    
+    FieldInFields = False
+End Function
+
+' Determine if a table or exists.
+' based on sample code of support.microsoftcom
+' ARGUMENTS:
+'    TName: The name of a table or query.
+'
+' RETURNS: True (it exists) or False (it does not exist).
+Private Function TableExists(ByVal TName As String) As Boolean
+    Dim Db As DAO.Database
+    Dim Found As Boolean
+    Dim test As String
+    
+    Const NAME_NOT_IN_COLLECTION As Integer = 3265
+    
+     ' Assume the table or query does not exist.
+    Found = False
+    Set Db = CurrentDb()
+    
+     ' Trap for any errors.
+    On Error Resume Next
+     
+     ' See if the name is in the Tables collection.
+    test = Db.TableDefs(TName).name
+    If err.number <> NAME_NOT_IN_COLLECTION Then Found = True
+    
+    ' Reset the error variable.
+    err = 0
+    
+    TableExists = Found
+End Function
+
+' Build SQL to export `tbl_name` sorted by each field from first to last
+Private Function TableExportSql(ByVal tbl_name As String) As String
+    Dim rs As Object ' DAO.Recordset
+    Dim fieldObj As Object ' DAO.Field
+    Dim sb() As String, count As Integer
+
+    Set rs = CurrentDb.OpenRecordset(tbl_name)
+    
+    sb = VCS_String.Sb_Init()
+    VCS_String.Sb_Append sb, "SELECT "
+    
+    count = 0
+    For Each fieldObj In rs.Fields
+        If count > 0 Then VCS_String.Sb_Append sb, ", "
+        VCS_String.Sb_Append sb, "[" & fieldObj.name & "]"
+        count = count + 1
+    Next
+    
+    VCS_String.Sb_Append sb, " FROM [" & tbl_name & "] ORDER BY "
+    
+    count = 0
+    For Each fieldObj In rs.Fields
+        DoEvents
+        If count > 0 Then VCS_String.Sb_Append sb, ", "
+        VCS_String.Sb_Append sb, "[" & fieldObj.name & "]"
+        count = count + 1
+    Next
+
+    TableExportSql = VCS_String.Sb_Get(sb)
+End Function
+
+' Export the lookup table `tblName` to `source\tables`.
+Public Sub ExportTableData(ByVal tbl_name As String, ByVal obj_path As String)
+    Dim fso As Object
+    Dim OutFile As Object
+    Dim rs As DAO.Recordset ' DAO.Recordset
+    Dim fieldObj As Object ' DAO.Field
+    Dim c As Long, value As Variant
+    
+    ' Checks first
+    If Not TableExists(tbl_name) Then
+        Debug.Print "Error: Table " & tbl_name & " missing"
+        Exit Sub
+    End If
+    
+    Set rs = CurrentDb.OpenRecordset(TableExportSql(tbl_name))
+    If rs.RecordCount = 0 Then
+        'why is this an error? Debug.Print "Error: Table " & tbl_name & "  empty"
+        rs.Close
+        Exit Sub
+    End If
+
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    ' open file for writing with Create=True, Unicode=True (USC-2 Little Endian format)
+    VCS_Dir.MkDirIfNotExist obj_path
+    Dim tempFileName As String
+    tempFileName = VCS_File.TempFile()
+
+    Set OutFile = fso.CreateTextFile(tempFileName, overwrite:=True, Unicode:=True)
+
+    c = 0
+    For Each fieldObj In rs.Fields
+        If c <> 0 Then OutFile.Write vbTab
+        c = c + 1
+        OutFile.Write fieldObj.name
+    Next
+    OutFile.Write vbCrLf
+
+    rs.MoveFirst
+    Do Until rs.EOF
+        c = 0
+        For Each fieldObj In rs.Fields
+            DoEvents
+            If c <> 0 Then OutFile.Write vbTab
+            c = c + 1
+            value = rs(fieldObj.name)
+            If IsNull(value) Then
+                value = vbNullString
+            Else
+                value = Replace(value, "\", "\\")
+                value = Replace(value, vbCrLf, "\n")
+                value = Replace(value, vbCr, "\n")
+                value = Replace(value, vbLf, "\n")
+                value = Replace(value, vbTab, "\t")
+            End If
+            OutFile.Write value
+        Next
+        OutFile.Write vbCrLf
+        rs.MoveNext
+    Loop
+    rs.Close
+    OutFile.Close
+
+    VCS_File.ConvertUcs2Utf8 tempFileName, obj_path & tbl_name & ".txt"
+    fso.DeleteFile tempFileName
+End Sub
+
+' Kill Table if Exists
+Private Sub KillTable(ByVal tblName As String, Db As Object)
+    If TableExists(tblName) Then
+        Db.execute "DROP TABLE [" & tblName & "]"
+    End If
+End Sub
+
+Public Sub ImportLinkedTable(ByVal tblName As String, ByRef obj_path As String)
+    Dim Db As DAO.Database
+    Dim fso As Object
+    Dim InFile As Object
+    
+    Set Db = CurrentDb
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    
+    Dim tempFilePath As String
+    tempFilePath = VCS_File.TempFile()
+    
+    ConvertUtf8Ucs2 obj_path & tblName & ".LNKD", tempFilePath
+    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
+    Set InFile = fso.OpenTextFile(tempFilePath, iomode:=ForReading, create:=False, Format:=TristateTrue)
+    
+    On Error GoTo err_notable:
+    DoCmd.DeleteObject acTable, tblName
+    
+    GoTo err_notable_fin
+    
+err_notable:
+    err.Clear
+    Resume err_notable_fin
+    
+err_notable_fin:
+    On Error GoTo Err_CreateLinkedTable:
+    
+    Dim td As DAO.TableDef
+    Set td = Db.CreateTableDef(InFile.readline())
+    
+    Dim connect As String
+    connect = InFile.readline()
+    If InStr(1, connect, "DATABASE=.\") Then 'replace relative path with literal path
+        connect = Replace(connect, "DATABASE=.\", "DATABASE=" & CurrentProject.Path & "\")
+    End If
+    td.connect = connect
+    
+    td.SourceTableName = InFile.readline()
+    Db.TableDefs.Append td
+    
+    GoTo Err_CreateLinkedTable_Fin
+    
+Err_CreateLinkedTable:
+    MsgBox err.Description, vbCritical, "ERROR: IMPORT LINKED TABLE"
+    Resume Err_CreateLinkedTable_Fin
+    
+Err_CreateLinkedTable_Fin:
+    'this will throw errors if a primary key already exists or the table is linked to an access database table
+    'will also error out if no pk is present
+    On Error GoTo Err_LinkPK_Fin:
+    
+    Dim Fields As String
+    Fields = InFile.readline()
+    Dim Field As Variant
+    Dim sql As String
+    sql = "CREATE INDEX __uniqueindex ON " & td.name & " ("
+    
+    For Each Field In Split(Fields, ";+")
+        sql = sql & "[" & Field & "]" & ","
+    Next
+    'remove extraneous comma
+    sql = Left$(sql, Len(sql) - 1)
+    
+    sql = sql & ") WITH PRIMARY"
+    CurrentDb.execute sql
+    
+Err_LinkPK_Fin:
+    On Error Resume Next
+    InFile.Close
+    
+End Sub
+
+' Import Table Definition
+Public Sub ImportTableDef(ByVal tblName As String, ByVal directory As String)
+    Dim filePath As String
+    filePath = directory & tblName & ".sql"
+    Dim Db As Object ' DAO.Database
+    Dim fso As Object
+    Dim InFile As Object
+    Dim buf As String
+    Dim p As Integer
+    Dim p1 As Integer
+    Dim strMsg As String
+    Dim s As Variant
+    Dim n As Integer
+    Dim i As Integer
+    Dim j As Integer
+    Dim tempFileName As String
+    tempFileName = VCS_File.TempFile()
+
+    n = -1
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    VCS_File.ConvertUtf8Ucs2 filePath, tempFileName
+    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
+    Set InFile = fso.OpenTextFile(tempFileName, iomode:=ForReading, create:=False, Format:=TristateTrue)
+    Set Db = CurrentDb
+    KillTable tblName, Db
+    buf = InFile.readline()
+    Do Until InFile.AtEndOfStream
+        buf = buf & InFile.readline()
+    Loop
+    
+    ' The following block is needed because "on update" actions may cause problems
+    For Each s In Split("UPDATE|DELETE", "|")
+      p = InStr(buf, "ON " & s & " CASCADE")
+      Do While p > 0
+          n = n + 1
+          ReDim Preserve K(n)
+          K(n).table = tblName
+          K(n).isUpdate = (s = "UPDATE")
+          
+          buf = Left$(buf, p - 1) & Mid$(buf, p + 18)
+          p = InStrRev(buf, "REFERENCES", p)
+          p1 = InStr(p, buf, "(")
+          K(n).foreignFields = Split(VCS_String.SubString(p1, buf, "(", ")"), ",")
+          K(n).foreignTable = Trim$(Mid$(buf, p + 10, p1 - p - 10))
+          p = InStrRev(buf, "CONSTRAINT", p1)
+          p1 = InStrRev(buf, "FOREIGN KEY", p1)
+          If (p1 > 0) And (p > 0) And (p1 > p) Then
+          ' multifield index
+              K(n).refFields = Split(VCS_String.SubString(p1, buf, "(", ")"), ",")
+          ElseIf p1 = 0 Then
+          ' single field
+          End If
+          p = InStr(p, "ON " & s & " CASCADE", buf)
+      Loop
+    Next
+    On Error Resume Next
+    For i = 0 To n
+        strMsg = K(i).table & " to " & K(i).foreignTable
+        strMsg = strMsg & "(  "
+        For j = 0 To UBound(K(i).refFields)
+            strMsg = strMsg & K(i).refFields(j) & ", "
+        Next j
+        strMsg = Left$(strMsg, Len(strMsg) - 2) & ") to ("
+        For j = 0 To UBound(K(i).foreignFields)
+            strMsg = strMsg & K(i).foreignFields(j) & ", "
+        Next j
+        strMsg = Left$(strMsg, Len(strMsg) - 2) & ") Check "
+        If K(i).isUpdate Then
+            strMsg = strMsg & " on update cascade " & vbCrLf
+        Else
+            strMsg = strMsg & " on delete cascade " & vbCrLf
+        End If
+    Next
+    On Error GoTo 0
+    Db.execute buf
+    InFile.Close
+    If Len(strMsg) > 0 Then MsgBox strMsg, vbOKOnly, "Correct manually"
+        
+End Sub
+
+' Import the lookup table `tblName` from `source\tables`.
+Public Sub ImportTableData(ByVal tblName As String, ByVal obj_path As String)
+    Dim Db As Object ' DAO.Database
+    Dim rs As Object ' DAO.Recordset
+    Dim fieldObj As Object ' DAO.Field
+    Dim fso As Object
+    Dim InFile As Object
+    Dim c As Long, buf As String, Values() As String, value As Variant
+
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    
+    Dim tempFileName As String
+    tempFileName = VCS_File.TempFile()
+    VCS_File.ConvertUtf8Ucs2 obj_path & tblName & ".txt", tempFileName
+    ' open file for reading with Create=False, Unicode=True (USC-2 Little Endian format)
+    Set InFile = fso.OpenTextFile(tempFileName, iomode:=ForReading, create:=False, Format:=TristateTrue)
+    Set Db = CurrentDb
+
+    Db.execute "DELETE FROM [" & tblName & "]"
+    Set rs = Db.OpenRecordset(tblName)
+    buf = InFile.readline()
+    Do Until InFile.AtEndOfStream
+        buf = InFile.readline()
+        If Len(Trim$(buf)) > 0 Then
+            Values = Split(buf, vbTab)
+            c = 0
+            rs.AddNew
+            For Each fieldObj In rs.Fields
+                DoEvents
+                value = Values(c)
+                If Len(value) = 0 Then
+                    value = Null
+                Else
+                    value = Replace(value, "\t", vbTab)
+                    value = Replace(value, "\n", vbCrLf)
+                    value = Replace(value, "\\", "\")
+                End If
+                rs(fieldObj.name) = value
+                c = c + 1
+            Next
+            rs.update
+        End If
+    Loop
+
+    rs.Close
+    InFile.Close
+    fso.DeleteFile tempFileName
+End Sub

source/modules/optimizer.bas

@@ -0,0 +1,166 @@
+Option Compare Database
+Option Explicit
+
+Public Function get_last_update_date(ByVal acType As Integer, ByVal name As String)
+On Error GoTo err
+
+    Select Case acType
+    
+        Case acTable
+            
+            get_last_update_date = DFirst("DateUpdate", "MSysObjects", "([Type]=1 or [Type]=4 or [Type]=6) and [name]='" & name & "'")
+        
+        Case acQuery
+        
+            get_last_update_date = DFirst("DateUpdate", "MSysObjects", "[Type]=5 and [name]='" & name & "'")
+        
+        Case acForm
+            
+            get_last_update_date = CurrentProject.AllForms(name).DateModified
+        
+        Case acReport
+            
+            get_last_update_date = CurrentProject.AllReports(name).DateModified
+        
+        Case acMacro
+            
+            get_last_update_date = CurrentProject.AllMacros(name).DateModified
+        
+        Case acModule
+            
+            get_last_update_date = CurrentProject.AllModules(name).DateModified
+            
+    End Select
+    
+    Exit Function
+err:
+    Debug.Print "get_last_update_date - erreur - " & acType & ", " & name & ": " & err.Description
+    get_last_update_date = #1/1/1900#
+End Function
+
+Public Function list_modified(acType As Integer)
+    Dim sources_date As Date
+    
+    list_modified = ""
+    
+    sources_date = get_sources_date()
+    
+    Dim rs As DAO.Recordset
+    Set rs = CurrentDb.OpenRecordset("SELECT * FROM MSysObjects WHERE " & typefilter(acType) & ";", _
+                                     dbOpenSnapshot)
+    If rs.RecordCount = 0 Then GoTo emptylist
+    
+    rs.MoveFirst
+    
+    Do Until rs.EOF
+        If rs![dateupdate] > sources_date Then
+            If Len(list_modified) > 0 Then
+                list_modified = list_modified & ";" & rs![name]
+            Else
+                list_modified = rs![name]
+            End If
+        End If
+        rs.MoveNext
+    Loop
+
+    Exit Function
+emptylist:
+End Function
+
+Public Function msg_list_modified() As String
+    Dim lstmod, obj_type_split, obj_type_label, obj_type_num As String
+    Dim obj_type, objname As Variant
+    
+    msg_list_modified = ""
+
+    For Each obj_type In Split( _
+        "tables|" & acTable & "," & _
+        "queries|" & acQuery & "," & _
+        "forms|" & acForm & "," & _
+        "reports|" & acReport & "," & _
+        "macros|" & acMacro & "," & _
+        "modules|" & acModule _
+        , "," _
+    )
+        obj_type_split = Split(obj_type, "|")
+        obj_type_label = obj_type_split(0)
+        obj_type_num = obj_type_split(1)
+
+        lstmod = list_modified(CInt(obj_type_num))
+        
+        If Len(lstmod) > 0 Then
+            msg_list_modified = msg_list_modified & "** " & UCase(obj_type_label) & " **" & vbNewLine
+            For Each objname In Split(lstmod, ";")
+                msg_list_modified = msg_list_modified & "    " & objname & vbNewLine
+            Next objname
+        End If
+    Next obj_type
+    
+
+End Function
+
+Public Function is_dirty(acType As Integer, name As String)
+
+    is_dirty = (get_last_update_date(acType, name) > get_sources_date)
+
+End Function
+
+Public Function get_sources_date() As Date
+
+    get_sources_date = CDate(vcs_param("sources_date", "01/01/1900 00:00:00"))
+
+End Function
+
+
+Public Sub update_sources_date()
+
+If Not vcs_tbl_exists() Then
+    Call create_vcs_tbl
+End If
+
+Call update_vcs_param("sources_date", CStr(Now))
+
+End Sub
+
+
+
+'NB: types msys
+'-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
+
+Private Function typefilter(acType) As String
+
+    Select Case acType
+        Case acTable
+            typefilter = "([Type]=1 or [Type]=4 or [Type]=6)"
+        Case acQuery
+            typefilter = "[Type]=5"
+        Case acForm
+            typefilter = "[Type]=-32768"
+        Case acReport
+            typefilter = "[Type]=-32764"
+        Case acModule
+            typefilter = "[Type]=-32761"
+        Case acMacro
+            typefilter = "[Type]=-32766"
+        Case Else
+            GoTo typerror
+    End Select
+
+Exit Function
+typerror:
+    MsgBox "typerror:" & acType & " is not a valid object type"
+    typefilter = ""
+End Function

source/modules/vcs.bas

@@ -1,4 +1,5 @@
 Option Compare Database
+Dim private_optimizer As Boolean
 
 Public Function vcsprompt()
 
@@ -7,61 +8,18 @@ Public Function vcsprompt()
 End Function
 
 
-'Public Function vcsprompt()
-'    Dim prompt, prompttext, warning As String
-'    Dim continue As Boolean
-'
-'    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 = ""
-'    continue = True
-'
-'    While continue
-'        prompt = InputBox(prompttext, "VCS", "")
-'
-'        If Right(prompt, 1) = "&" Then
-'            prompt = Left(prompt, Len(prompt) - 1)
-'        Else
-'            continue = False
-'        End If
-'
-'        Select Case prompt
-'
-'            Case "makesources"
-'
-'                Call make_sources
-'                MsgBox "Done"
-'
-'            Case "update"
-'
-'                Call update_from_sources
-'                MsgBox "Done"
-'
-'            Case "sync"
-'
-'                Call sync
-'                MsgBox "Done"
-'
-'            Case vbNullString
-'
-'
-'            Case Else
-'                MsgBox "Unknown command"
-'
-'        End Select
-'whil:
-'    Wend
-'
-'Exit Function
-'
-'End Function
-
-
-Public Function make_sources()
+Public Function make_sources(ByVal options As String)
 'creates the source-code of the app
 
+    If Not InStr(options, "-f") > 0 Then
+        Dim msg As String
+        msg = "** VCS OPTIMIZER **"
+        msg = msg & vbNewLine & "Seuls les objets suivant seront exportés:" & vbNewLine
+        msg = msg & msg_list_modified()
+        If Not MsgBox(msg, vbOKCancel) = vbCancel Then Exit Function
+        Call activate_optimizer
+    End If
+
     Debug.Print "Zip the app file"
     Call zip_app_file
     Debug.Print "> done"
@@ -283,10 +241,40 @@ End Function
 Function vcs_tbl_exists()
 On Error GoTo err
     vcs_tbl_exists = (CurrentDb.TableDefs("ztbl_vcs").name = "ztbl_vcs")
+Exit Function
 err:
     If err.number = 3265 Then
         vcs_tbl_exists = False
     Else
         MsgBox "Error: " & err.Description, vbCritical
     End If
+End Function
+
+Public Function create_vcs_tbl()
+    CurrentDb.execute "SELECT 'include_tables' as key, '' as val INTO ztbl_vcs " & _
+                       "FROM modele_ztbl_vcs;"
+End Function
+
+Public Function update_vcs_param(ByVal key As String, ByVal val As String)
+
+    If DCount("key", "ztbl_vcs", "[key]='" & key & "'") = 1 Then
+        CurrentDb.execute "UPDATE ztbl_vcs SET ztbl_vcs.val = '" & val & "' " & _
+                            "WHERE (((ztbl_vcs.key)='" & key & "'));"
+    Else
+        CurrentDb.execute "INSERT INTO ztbl_vcs ( val, [key] ) " & _
+                           "SELECT '" & val & "' AS Expr1, '" & key & "' AS Expr2;"
+    End If
+
+End Function
+
+Public Sub activate_optimizer()
+
+    private_optimizer = True
+
+End Sub
+
+Public Function optimizer_activated()
+
+    optimizer_activated = private_optimizer
+
 End Function

source/tables/tbl_commands.txt

@@ -1,5 +1,5 @@
 cmd_name	function	description	order	with_args
 configure_git_repo	config_git_repo	Configure an existing Git repository to be used with VCS	3	Faux
 gitcmd	gitcmd	Runs a git command	4	Vrai
-make_sources	make_sources	Makes the source-code files from the current project	1	Faux
+make_sources	make_sources	Makes the source-code files from the current project (-f to force a complete export)	1	Vrai
 update_from_sources	update_from_sources	Update the current project within the source-code files	2	Faux

source/tbldef/ztbl_vcs.sql

@@ -0,0 +1,4 @@
+CREATE TABLE [ztbl_vcs] (
+  [key] VARCHAR (255),
+  [val] VARCHAR (255)
+)

test/source/forms/frm_Admin.bas

@@ -0,0 +1,840 @@
+Version =20
+VersionRequired =20
+Begin Form
+    RecordSelectors = NotDefault
+    MaxButton = NotDefault
+    MinButton = NotDefault
+    ControlBox = NotDefault
+    AutoCenter = NotDefault
+    NavigationButtons = NotDefault
+    DividingLines = NotDefault
+    AllowDesignChanges = NotDefault
+    DefaultView =0
+    ScrollBars =0
+    PictureAlignment =2
+    DatasheetGridlinesBehavior =3
+    GridY =10
+    Width =10714
+    DatasheetFontHeight =11
+    ItemSuffix =16
+    Right =9030
+    Bottom =12345
+    DatasheetGridlinesColor =14806254
+    RecSrcDt = Begin
+        0x98cd09ff0f38e440
+    End
+    OnCurrent ="[Event Procedure]"
+    DatasheetFontName ="Calibri"
+    PrtMip = Begin
+        0x6801000068010000680100006801000000000000201c0000e010000001000000 ,
+        0x010000006801000000000000a10700000100000001000000
+    End
+    FilterOnLoad =0
+    ShowPageMargins =0
+    DisplayOnSharePointSite =1
+    DatasheetAlternateBackColor =15921906
+    DatasheetGridlinesColor12 =0
+    FitToScreen =1
+    DatasheetBackThemeColorIndex =1
+    BorderThemeColorIndex =3
+    ThemeFontIndex =1
+    ForeThemeColorIndex =0
+    AlternateBackThemeColorIndex =1
+    AlternateBackShade =95.0
+    Begin
+        Begin Label
+            BackStyle =0
+            FontSize =11
+            FontName ="Calibri"
+            ThemeFontIndex =1
+            BackThemeColorIndex =1
+            BorderThemeColorIndex =0
+            BorderTint =50.0
+            ForeThemeColorIndex =0
+            ForeTint =50.0
+            GridlineThemeColorIndex =1
+            GridlineShade =65.0
+        End
+        Begin CommandButton
+            Width =1701
+            Height =283
+            FontSize =11
+            FontWeight =400
+            FontName ="Calibri"
+            ForeThemeColorIndex =0
+            ForeTint =75.0
+            GridlineThemeColorIndex =1
+            GridlineShade =65.0
+            UseTheme =1
+            Shape =1
+            Gradient =12
+            BackThemeColorIndex =4
+            BackTint =60.0
+            BorderLineStyle =0
+            BorderColor =16777215
+            BorderThemeColorIndex =4
+            BorderTint =60.0
+            ThemeFontIndex =1
+            HoverThemeColorIndex =4
+            HoverTint =40.0
+            PressedThemeColorIndex =4
+            PressedShade =75.0
+            HoverForeThemeColorIndex =0
+            HoverForeTint =75.0
+            PressedForeThemeColorIndex =0
+            PressedForeTint =75.0
+        End
+        Begin CheckBox
+            BorderLineStyle =0
+            LabelX =230
+            LabelY =-30
+            BorderThemeColorIndex =1
+            BorderShade =65.0
+            GridlineThemeColorIndex =1
+            GridlineShade =65.0
+        End
+        Begin Subform
+            BorderLineStyle =0
+            Width =1701
+            Height =1701
+            BorderThemeColorIndex =1
+            GridlineThemeColorIndex =1
+            GridlineShade =65.0
+            BorderShade =65.0
+            ShowPageHeaderAndPageFooter =1
+        End
+        Begin FormHeader
+            Height =5986
+            BackColor =13611711
+            Name ="EntêteFormulaire"
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+            Begin
+                Begin Label
+                    OverlapFlags =85
+                    TextAlign =2
+                    Left =850
+                    Top =170
+                    Width =3232
+                    Height =340
+                    FontSize =13
+                    FontWeight =700
+                    BorderColor =8355711
+                    Name ="Étiquette0"
+                    Caption ="Outils d'Administration"
+                    GridlineColor =10921638
+                    LayoutCachedLeft =850
+                    LayoutCachedTop =170
+                    LayoutCachedWidth =4082
+                    LayoutCachedHeight =510
+                    ForeTint =100.0
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =283
+                    Top =170
+                    Width =501
+                    Height =336
+                    ForeColor =4210752
+                    Name ="Commande1"
+                    Caption ="Commande1"
+                    ControlTipText ="Fermer formulaire"
+                    GridlineColor =10921638
+                    OnClickEmMacro = Begin
+                        Version =196611
+                        ColumnsShown =8
+                        Begin
+                            Action ="Close"
+                            Argument ="-1"
+                            Argument =""
+                            Argument ="0"
+                        End
+                        Begin
+                            Comment ="_AXL:<?xml version=\"1.0\" encoding=\"UTF-16\" standalone=\"no\"?>\015\012<UserI"
+                                "nterfaceMacro For=\"Commande1\" xmlns=\"http://schemas.microsoft.com/office/acce"
+                                "ssservices/2009/11/application\" xmlns:a=\"http://schemas.microsoft.com/office/a"
+                                "ccessservices/2009/11/forms\"><"
+                        End
+                        Begin
+                            Comment ="_AXL:Statements><Action Name=\"CloseWindow\"/></Statements></UserInterfaceMacro>"
+                        End
+                    End
+                    ImageData = Begin
+                        0x2800000010000000100000000100200000000000000000000000000000000000 ,
+                        0x0000000000000000000000000000000000000000000000000000000010081080 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x000000000000000000000000000000000000000040485020100810e0104050ff ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000000000000000000040404080405860ff106890ff2080a0f0 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000607070ff80a0b0ff4080a0ff20a0d0ff40a8e0ff2078a0ff ,
+                        0x101020ff101020ff000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000708890ffa0d8f0ff60d0ffff50c0f0ff30a8e0ff1080b0ff ,
+                        0xe0d8d0ff102020ff000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000708890ffb0e8f0ff80e0ffff60c8f0ff50b8f0ff1088c0ff ,
+                        0xf0d8d0ff202830ff000000000000000090482030904820ff0000000000000000 ,
+                        0x0000000000000000808890ffb0e8f0ff80e0ffff60d0ffff404050ff1090c0ff ,
+                        0xf0e0d0ff303840ff0000000090482030a05030ffa05020ff0000000000000000 ,
+                        0x00000000000000008090a0ffc0f0ffff90e0ffff70d8ffff60c8f0ff0090c0ff ,
+                        0xf0e0e0ff404050ff90482030a05030ffd07840ffb05830ffa05020ffa04820ff ,
+                        0x904820ff904820ff8090a0ffc0f0ffffa0e8ffff80d8ffff70d0f0ff40b0e0ff ,
+                        0xf0e8e0ff605050ffa05830ffe08860fff09060fff08850ffe07850ffd07040ff ,
+                        0xb06840ff904820ff8098a0ffc0f0ffffa0e8ffff90e8ffff80e0ffff80b8d0ff ,
+                        0xf0e8e0ffe09870ffffc0a0ffffb090ffffa070fff09060fff08850ffe07850ff ,
+                        0xd07040ffa05020ff8098a0ffc0f0ffffc0f8ffffa0e0f0ff90a8b0ffc0c8d0ff ,
+                        0xf0f0e0ff908080fff0a070ffffc0a0ffffb090ffffb090ffffa880fff0a080ff ,
+                        0xe09870ffb05030ff90a0a0ffe0f8ffffb0c8d0ff90a0b0fff0f0f0fffff8f0ff ,
+                        0xf0f0f0ff607080ffe0987050f0a070ffffc0a0ffd06830ffe09870ffe09060ff ,
+                        0xe08860ffe08050ff90a0b0ff90a8b0ffc0c8d0ffffffffffffffffffffffffff ,
+                        0xffffffff708890ff00000000e0987050e09870ffd07040ff0000000000000000 ,
+                        0x000000000000000090a0b0ff90a0b0ff90a0b0ff90a0b0ff90a0a0ff8098a0ff ,
+                        0x8098a0ff9098a0ff0000000000000000e0987050e09870ff0000000000000000 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000000000000000000000000000000000000000000000000000 ,
+                        0x0000000000000000
+                    End
+
+                    LayoutCachedLeft =283
+                    LayoutCachedTop =170
+                    LayoutCachedWidth =784
+                    LayoutCachedHeight =506
+                    Gradient =0
+                    BackColor =16183539
+                    BackThemeColorIndex =-1
+                    BackTint =100.0
+                    BorderColor =12029087
+                    BorderThemeColorIndex =-1
+                    BorderTint =100.0
+                    HoverColor =15060409
+                    PressedColor =9592887
+                    HoverForeColor =4210752
+                    PressedForeColor =4210752
+                    WebImagePaddingLeft =2
+                    WebImagePaddingTop =2
+                    WebImagePaddingRight =1
+                    WebImagePaddingBottom =1
+                    Overlaps =1
+                End
+                Begin CheckBox
+                    OverlapFlags =85
+                    Left =283
+                    Top =3039
+                    Width =340
+                    Height =283
+                    ColumnOrder =0
+                    TabIndex =1
+                    BorderColor =10921638
+                    Name ="AvertSQL"
+                    AfterUpdate ="[Event Procedure]"
+                    OnClick ="[Event Procedure]"
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =283
+                    LayoutCachedTop =3039
+                    LayoutCachedWidth =623
+                    LayoutCachedHeight =3322
+                    Begin
+                        Begin Label
+                            OverlapFlags =247
+                            Left =512
+                            Top =3004
+                            Width =4245
+                            Height =555
+                            BorderColor =8355711
+                            Name ="Étiquette3"
+                            Caption ="Activer / Désactiver les avertissements SQL (lors de mises à jour, suppressions."
+                                "..)"
+                            GridlineColor =10921638
+                            LayoutCachedLeft =512
+                            LayoutCachedTop =3004
+                            LayoutCachedWidth =4757
+                            LayoutCachedHeight =3559
+                            ForeTint =100.0
+                        End
+                    End
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =793
+                    Width =4245
+                    Height =397
+                    TabIndex =2
+                    ForeColor =16777215
+                    Name ="Commande4"
+                    Caption ="Ouvrir les paramètres utilisateurs"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =90
+                    TopPadding =45
+                    RightPadding =105
+                    BottomPadding =150
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =793
+                    LayoutCachedWidth =4755
+                    LayoutCachedHeight =1190
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingLeft =2
+                    WebImagePaddingTop =2
+                    WebImagePaddingRight =2
+                    WebImagePaddingBottom =2
+                    Overlaps =1
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =1586
+                    Width =4245
+                    Height =397
+                    TabIndex =3
+                    ForeColor =16777215
+                    Name ="Commande5"
+                    Caption ="Droits d'accès"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =60
+                    RightPadding =75
+                    BottomPadding =120
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =1586
+                    LayoutCachedWidth =4755
+                    LayoutCachedHeight =1983
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingTop =1
+                    Overlaps =1
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =2323
+                    Width =4245
+                    Height =397
+                    TabIndex =4
+                    ForeColor =16777215
+                    Name ="Commande6"
+                    Caption ="Suivi des versions"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =60
+                    RightPadding =75
+                    BottomPadding =120
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =2323
+                    LayoutCachedWidth =4755
+                    LayoutCachedHeight =2720
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingTop =1
+                    Overlaps =1
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =4422
+                    Width =4256
+                    Height =396
+                    TabIndex =5
+                    ForeColor =16777215
+                    Name ="ImportPDA"
+                    Caption ="Import Direct depuis PDA"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =60
+                    RightPadding =75
+                    BottomPadding =120
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =4422
+                    LayoutCachedWidth =4766
+                    LayoutCachedHeight =4818
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingTop =1
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =3775
+                    Width =4245
+                    Height =397
+                    TabIndex =6
+                    ForeColor =16777215
+                    Name ="ToutImpr"
+                    Caption ="Tout Imprimer*"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =60
+                    RightPadding =75
+                    BottomPadding =120
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =3775
+                    LayoutCachedWidth =4755
+                    LayoutCachedHeight =4172
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingTop =1
+                End
+                Begin CommandButton
+                    OverlapFlags =85
+                    Left =510
+                    Top =5106
+                    Width =4252
+                    Height =393
+                    TabIndex =7
+                    ForeColor =16777215
+                    Name ="PeripleToutExporter"
+                    Caption ="PERIPLE: Tout Exporter"
+                    OnClick ="[Event Procedure]"
+                    LeftPadding =60
+                    RightPadding =75
+                    BottomPadding =120
+                    GridlineColor =10921638
+
+                    LayoutCachedLeft =510
+                    LayoutCachedTop =5106
+                    LayoutCachedWidth =4762
+                    LayoutCachedHeight =5499
+                    ForeThemeColorIndex =1
+                    ForeTint =100.0
+                    Gradient =25
+                    BackColor =10642560
+                    BackThemeColorIndex =7
+                    BackTint =100.0
+                    BorderColor =10642560
+                    BorderThemeColorIndex =7
+                    BorderTint =100.0
+                    HoverColor =11895705
+                    HoverThemeColorIndex =7
+                    HoverTint =80.0
+                    PressedColor =8605542
+                    PressedThemeColorIndex =7
+                    PressedShade =80.0
+                    HoverForeThemeColorIndex =1
+                    HoverForeTint =100.0
+                    PressedForeThemeColorIndex =1
+                    PressedForeTint =100.0
+                    Shadow =-1
+                    QuickStyle =33
+                    QuickStyleMask =-1
+                    WebImagePaddingTop =1
+                End
+                Begin Label
+                    Visible = NotDefault
+                    OverlapFlags =85
+                    TextAlign =2
+                    Left =625
+                    Top =5703
+                    Width =3911
+                    Height =283
+                    BorderColor =8355711
+                    Name ="txt_prog"
+                    Caption ="..."
+                    GridlineColor =10921638
+                    LayoutCachedLeft =625
+                    LayoutCachedTop =5703
+                    LayoutCachedWidth =4536
+                    LayoutCachedHeight =5986
+                    ForeTint =100.0
+                End
+            End
+        End
+        Begin Section
+            Height =0
+            BackColor =13611711
+            Name ="Détail"
+            AlternateBackColor =15921906
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+        End
+        Begin FormFooter
+            Height =396
+            BackColor =13611711
+            Name ="PiedFormulaire"
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+            Begin
+                Begin Label
+                    FontItalic = NotDefault
+                    OverlapFlags =85
+                    Left =120
+                    Top =60
+                    Width =8775
+                    Height =285
+                    BorderColor =8355711
+                    Name ="Étiquette12"
+                    Caption ="* Imprime un exemplaire de chaque formulaire depuis le début de l'année pour l'a"
+                        "gent choisi."
+                    GridlineColor =10921638
+                    LayoutCachedLeft =120
+                    LayoutCachedTop =60
+                    LayoutCachedWidth =8895
+                    LayoutCachedHeight =345
+                    ForeTint =100.0
+                End
+            End
+        End
+    End
+End
+CodeBehindForm
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = True
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Option Compare Database
+
+Private Sub AvertSQL_AfterUpdate()
+If Me.AvertSQL = True Then
+ Call MAJParametre("AvertSQL", 1)
+Else
+ Call MAJParametre("AvertSQL", 0)
+End If
+
+Me.Refresh
+End Sub
+
+Private Sub Commande4_Click()
+DoCmd.OpenForm "frm_ParamUtil"
+End Sub
+
+Private Sub Commande5_Click()
+DoCmd.OpenForm "frm_acces"
+End Sub
+
+Private Sub Commande6_Click()
+DoCmd.OpenForm "frm_SuiviVersions"
+End Sub
+
+Private Sub Form_Current()
+If parametre("AvertSQL") = 1 Then
+ Me.AvertSQL = True
+Else
+ Me.AvertSQL = False
+End If
+
+
+End Sub
+
+
+Private Sub ImportPDA_Click()
+Dim fichier As String
+Dim rep As String
+Dim nomFichier As String
+Dim strMAJImportRH, sql, critere As String
+Dim DejaImporte As Integer
+Dim CodeAgent As String
+Dim moisRH, anneeRH As Integer
+Dim rs As DAO.Recordset
+
+DejaImporte = 0
+
+'chercher le nom du fichier
+fichier = Nz(ChercherNomFichier(), "")
+
+If fichier = "" Then
+    Exit Sub
+End If
+
+'''''''procédure d'import du xml'''''''
+'vider la table d'importation rapport
+
+DoCmd.SetWarnings False
+DoCmd.RunSQL ("DELETE * FROM Rapport;")
+
+
+'test si fichier déja importé
+
+nomFichier = ExtraitNomFichier(fichier)
+rep = ExtraitNomRep(fichier)
+
+Call MAJParametre("RepXML", rep)
+
+DoCmd.SetWarnings False
+
+If DCount("FichierXML", "tbl_ImportRH", "[FichierXML]='" & nomFichier & "'") > 0 Or DCount("FichierXML", "tbl_ImportRH", "[FichierXML]='" & Right(nomFichier, (Len(nomFichier) - 2)) & "'") > 0 Then
+ If MsgBox("Attention, ce fichier semble avoir déja été importé. Le réimport supprimera toutes les anciennes données relatives à ce fichier. Voulez vous continuer?", vbYesNo) = vbNo Then Exit Sub
+ DejaImporte = 1
+ sql = "DELETE * FROM tbl_ImportRH WHERE [FichierXML]='" & nomFichier & "' OR [FichierXML]='" & Right(nomFichier, (Len(nomFichier) - 2)) & "';"
+ DoCmd.RunSQL sql
+End If
+
+'appeler la procédure d'import XML
+Call ImportXMLPDA(fichier)
+
+strShortFileName = nomFichier
+
+'TRANSFERT DES DONNEES RH VERS tbl_ImportRH (reprendre le code SQL du module d'import PDA)
+strUpdateImportRH = "INSERT INTO tbl_ImportRH ( CodeLigne, CodeAgent, DateRH, CodeChantier, CodeLocalisation, Localisation, strCategorieInterventionId, HeureSup1, HeureSup2, HeureSupDimanche, Repas, DistanceTranche1, VehiculePersoTranche1, DistanceTranche2, VehiculePersoTranche2, Remarque, Depart, FichierXML, DateImport, ResponsableImport ) " & _
+                    "SELECT Rapport.Id, Rapport.CodeAgent, ReformateDate([datedebut]) AS DDebut, Rapport.CodeChantier, Rapport.CodeLocalisation, DLookUp('strTiersMnemo','tblTiers','lngTiersId = ' & [CodeLocalisation]& ' ') AS Localisation, " & _
+                    "Rapport.CodeNatureRealisation, Rapport.HeureSup1, Rapport.HeureSup2, Rapport.HeureSupDimanche, Rapport.Repas, Rapport.DistanceTranche1, Rapport.VehiculePersoTranche1, Rapport.DistanceTranche2, Rapport.VehiculePersoTranche2, Rapport.Remarque, Rapport.Depart, '" & strShortFileName & "' AS FichierXML, Now() AS DateImport, Environ('Username') AS ResponsableImport " & _
+                    "FROM Rapport " & _
+                    "WHERE (((Rapport.HeureSup1) Is Not Null) AND ((Rapport.HeureSup2) Is Not Null) AND ((Rapport.HeureSupDimanche) Is Not Null) AND ((Rapport.Repas) Is Not Null) AND ((Rapport.DistanceTranche1) Is Not Null) AND ((Rapport.VehiculePersoTranche1) Is Not Null) AND ((Rapport.DistanceTranche2) Is Not Null) AND ((Rapport.VehiculePersoTranche2) Is Not Null));"
+
+DoCmd.RunSQL strUpdateImportRH
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_ImportRH WHERE [FichierXML]='" & nomFichier & "';")
+
+If rs.RecordCount = 0 Then
+ MsgBox "Données importées dans tbl_ImportRH; Erreur dans le retraitement des données, veuillez procéder manuellement."
+ Exit Sub
+End If
+
+rs.MoveFirst
+CodeAgent = rs![CodeAgent]
+moisRH = Month(rs![DateRH])
+anneeRH = Year(rs![DateRH])
+
+If CodeAgent = "" Or Not anneeRH > 2000 Or Not moisRH <= 12 Or Not moisRH > 0 Then
+ MsgBox "Données importées dans tbl_ImportRH; Erreur dans le retraitement des données, veuillez procéder manuellement."
+ Exit Sub
+End If
+
+critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+'on supprime la ligne correspondante de la table tbl_suivi, puis on lance le form "frm_chargement"
+sql = "DELETE * FROM tbl_SuiviRH WHERE " & critere & ";"
+DoCmd.RunSQL sql
+
+DoCmd.SetWarnings True
+
+Call Chargement
+
+
+End Sub
+
+Private Sub PeripleToutExporter_Click()
+Dim moisRH, anneeRH, essai As Integer
+Dim sql As String
+Dim rs As DAO.Recordset
+
+If Not CurrentProject.AllForms("frm_menu").IsLoaded Then
+  MsgBox "Le formulaire menu doit être ouvert"
+  GoTo fin
+End If
+moisRH = forms![frm_menu].moisRH
+anneeRH = forms![frm_menu].anneeRH
+
+If MsgBox("Vous aller exporter vers le serveur Sharepoint les données de tous les agents pour la période suivante:" & _
+          vbNewLine & moisRH & "\" & anneeRH, vbOKCancel) = vbCancel Then
+    MsgBox "Opération annulée"
+    GoTo fin
+End If
+
+DoCmd.Hourglass True
+'test connexion sharepoint:
+essai = 0
+While testConnexionLecteur(lecteurVirtuel, repHttp) = False
+   Call Attendre(500)
+   essai = essai + 1
+   If essai >= 3 Then
+      MsgBox "Erreur: impossible de se connecter au serveur sharepoint, les fichiers seront créés ici: " & vbNewLine & _
+               rep & nomFichier
+   End If
+Wend
+
+sql = "SELECT tbl_Agents.CodeAgent, tbl_Agents.Nom " & _
+      "From tbl_Agents " & _
+      "GROUP BY tbl_Agents.CodeAgent, tbl_Agents.Nom, tbl_Agents.[CodeAgent] " & _
+      "HAVING (((tbl_Agents.[CodeAgent]) In (SELECT [CodeAgent] FROM tbl_ImportRH WHERE Month([DateRH])=" & moisRH & " AND Year([DateRH])=" & anneeRH & ";))) " & _
+      "ORDER BY tbl_Agents.Nom;"
+'Debug.Print sql
+Set rs = CurrentDb.OpenRecordset(sql)
+
+Me.txt_prog.Visible = True
+
+If Not rs.RecordCount > 0 Then
+  MsgBox "Erreur: aucune donnée à exporter pour cette période"
+  GoTo fin
+End If
+rs.MoveLast
+rs.MoveFirst
+
+Do Until rs.EOF = True
+  Me.txt_prog.Caption = rs.AbsolutePosition & "/" & rs.RecordCount
+  If VerifDonneesExport(rs![CodeAgent], moisRH, anneeRH) = True Then
+    Call Periple_MajTableTampon(rs![CodeAgent], moisRH, anneeRH, True)
+    'Call Periple_ExportXML(True)
+  Else
+    MsgBox rs![Nom] & " - Vous devez corriger les erreurs détectées dans les données pour pouvoir les exporter."
+  End If
+  rs.MoveNext
+Loop
+
+fin:
+  On Error GoTo 0
+  DoCmd.Hourglass False
+  Me.txt_prog.Visible = False
+  Set rs = Nothing
+  Exit Sub
+err:
+  MsgBox "Erreur: " & err.Description
+  GoTo fin
+End Sub
+
+Private Sub ToutImpr_Click()
+Dim CodeAgent, msg, critere, imprimante As String
+Dim rs As DAO.Recordset
+
+CodeAgent = Nz(InputBox("Code de l'agent?"), "")
+
+If Not Len(CodeAgent) > 0 Then Exit Sub
+If IsNull(DLookup("CodeAgent", "tbl_Agents", "[CodeAgent]='" & CodeAgent & "'")) Then
+ MsgBox ("Code non trouvé dans tbl_Agents")
+ Exit Sub
+End If
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_SuiviRH WHERE [AnneeRH]=" & Year(Now()) & " AND [CodeAgent]='" & CodeAgent & "' ORDER BY [moisRH];")
+
+If Not rs.RecordCount > 0 Then
+ MsgBox ("Pas de données trouvées pour l'année en cours")
+ Exit Sub
+End If
+
+rs.MoveFirst
+Do Until rs.EOF = True
+ msg = msg & "," & MonthName(rs![moisRH])
+rs.MoveNext
+Loop
+
+msg = "Vous allez imprimer les formulaires des mois suivants: " & vbNewLine & Right(msg, Len(msg) - 1)
+
+If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
+
+'selection de l'imprimante utilisateur (cf. tbl_ParamUtil)
+imprimante = Nz(DLookup("valeur", "tbl_ParamUtil", "[parametre]='imprimante' AND [user]='" & CurrentUser & "'"), "")
+If imprimante = "" Then
+ MsgBox "Pas d'imprimante définie pour cet utilisateur (cf. tbl_parametre)"
+ Exit Sub
+End If
+NumIMP = 0
+NombreImp = Application.Printers.Count
+For Each ImpCherche In Application.Printers
+ If ImpCherche.DeviceName = imprimante Then
+  Set Application.Printer = Application.Printers(NumIMP)
+  Exit For
+ Else
+  NumIMP = NumIMP + 1
+ End If
+Next ImpCherche
+
+rs.MoveFirst
+Do Until rs.EOF = True
+ critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & rs![moisRH] & " AND [AnneeRH]=" & rs![anneeRH]
+ Call ImprEtats("Et_FormDep", 1, critere)
+ Call ImprEtats("Et_FormHS", 1, critere)
+ Call ImprEtats("Et_RecapEFD", 1, critere)
+ Call ImprEtats("Et_EtFraisDep", 1, critere)
+rs.MoveNext
+Loop
+
+Set Application.Printer = Nothing
+
+
+End Sub

test/source/macros/_AutoExec.bas

@@ -0,0 +1,17 @@
+Version =196611
+ColumnsShown =0
+Begin
+    Action ="RunCode"
+    Argument ="Chargement()"
+End
+Begin
+    Comment ="_AXL:<?xml version=\"1.0\" encoding=\"UTF-16\" standalone=\"no\"?>\015\012<UserI"
+        "nterfaceMacro MinimumClientDesignVersion=\"14.0.0000.0000\" xmlns=\"http://schem"
+        "as.microsoft.com/office/accessservices/2009/11/application\" xmlns:a=\"http://sc"
+        "hemas.microsoft.com/office/acc"
+End
+Begin
+    Comment ="_AXL:essservices/2009/11/forms\"><Statements><Action Name=\"RunCode\"><Argument "
+        "Name=\"FunctionName\">Chargement()</Argument></Action></Statements></UserInterfa"
+        "ceMacro>"
+End

test/source/modules/ChargementAppli.bas

@@ -0,0 +1,232 @@
+Option Compare Database
+'
+
+Public Function Chargement()
+
+Dim frm As Form
+Dim sql, msg1, msg2, msg3, msg3tmp, erreurs, resultat, critere, agent As String
+Dim i, co, compte, avertissement As Integer
+Dim db As DAO.Database
+Dim rsS, rsC As DAO.Recordset 'pour rs Source et rs Cible
+Set db = CurrentDb
+Dim verifversion, VersionPDA As Integer
+Dim pause As Integer  'si égal à 1 à la fin, pas de fermeture auto
+Dim IDSuivi As Double
+Dim Bloque As Integer
+Dim errImport As Boolean
+
+pause = 0
+Bloque = 0
+avertissement = 0 'pas d'avertissement pour le chargement
+
+SysCmd acSysCmdSetStatus, "Chargement de l'application - veuillez patienter"
+
+'vérif utilisateur
+co = connexion
+
+'intialisation formulaire
+DoCmd.OpenForm "frm_chargement"
+
+Set frm = Application.forms("frm_chargement")
+
+With frm
+    .Bloque = False
+    .Continuer.Visible = False
+    .Quitter.Visible = False
+     If Right(DLookup("parametre", "tbl_parametre", "valeur2='mdb_loc'"), 1) = "-" Then
+      'verif de la version  de l'application (uniquement si on fonctionne en réseau
+      verifversion = VerificationVersion()
+      If verifversion > 0 Then
+       msg1 = "Version à jour"
+      Else
+       msg1 = "(!) VOTRE VERSION DE L'APPLICATION N'EST PAS A JOUR (!)"
+       pause = 1
+       Bloque = 1
+       Call Mail_Maj
+      End If
+     Else
+      msg1 = "Appli en local"
+     End If
+     .txt_msg.Caption = msg1
+      'verif de la version  de l'application PDA
+      'VersionPDA = VerifVersionPDA()
+      'If VersionPDA > 0 Then
+      ' msg2 = "Version PDA à jour"
+      'Else
+      ' msg2 = "Votre version de PDA n'est pas à jour."
+      'End If
+      '.txt_msg.Caption = msg1 & vbNewLine & vbNewLine & msg2
+      msg2 = ""
+    
+      'si appli à jour, on continue. sinon, on quitte. si administrateur, on continue, mais pas d'analyses des données
+      If Bloque = 0 Then
+       msg3tmp = "Actualisation des données... Veuillez patienter."
+       .txt_msg.Caption = msg1 & vbNewLine & vbNewLine & msg2 & vbNewLine & vbNewLine & msg3tmp
+       'recherche d'éventuelles données à importer
+       sql = "SELECT r_LstImports.CodeAgent, r_LstImports.MoisRH, r_LstImports.anneerh " & _
+             "FROM tbl_SuiviRH RIGHT JOIN r_LstImports ON (tbl_SuiviRH.AnneeRH = r_LstImports.anneerh) AND (tbl_SuiviRH.MoisRH = r_LstImports.MoisRH) AND (tbl_SuiviRH.CodeAgent = r_LstImports.CodeAgent) " & _
+             "WHERE (((tbl_SuiviRH.CodeAgent) Is Null)) AND (((tbl_SuiviRH.MoisRH) Is Null)) AND (((tbl_SuiviRH.AnneeRH) Is Null));"
+       Debug.Print sql
+       Set rsS = db.OpenRecordset(sql)
+    
+       If Not rsS.RecordCount > 0 Then
+       'rien de neuf à importer
+         msg3 = "Données à jour"
+         .txt_msg.Caption = msg1 & vbNewLine & vbNewLine & msg2
+     
+       Else
+         
+         rsS.MoveLast
+         rsS.MoveFirst
+         compte = rsS.RecordCount
+         If compte > 0 Then pause = 1
+    
+          'maj des données
+          Do Until rsS.EOF = True
+           errImport = False
+           If Not Len(Nz(rsS![CodeAgent], "")) > 0 Or Not rsS![anneeRH] > 2000 Or Not rsS![moisRH] <= 12 Or Not rsS![moisRH] > 0 Then
+            erreurs = erreurs & "; " & "Import Annulé: le fichier " & nomFichier & " est peut-être corrompu..."
+            pause = 1
+           Else
+            'création d'une nouvelle ligne dans tbl_SuiviRH
+            IDSuivi = ajoutSuivi(rsS![CodeAgent], rsS![moisRH], rsS![anneeRH])
+    
+            'les champs mois et annee seront utilisés par les fonctions PeriodeAgent et PeriodeBareme au cours du chargement
+            '.mois = rsS![r_LstImports.MoisRH]
+            '.Annee = rsS![r_LstImports.AnneeRH]
+            'analyse des données (desactivé pour cause de lenteur)
+            'resultat = AnalyseDonnees(IDSuivi, rsS![r_LstImports.CodeAgent], rsS![r_LstImports.MoisRH], rsS![r_LstImports.AnneeRH], avertissement)
+            
+            If IDSuivi > 0 Then
+              agent = Nz(DLookup("[Nom]", "[r_Agents]", "[CodeAgent]='" & rsS![CodeAgent] & "'"), rsS![CodeAgent]) & " (" & rsS![CodeAgent] & ")"
+              msg3 = msg3 & vbNewLine & "Importé: " & agent & ", " & rsS![moisRH] & "/" & rsS![anneeRH] & VerifImport(rsS![CodeAgent], rsS![moisRH], rsS![anneeRH])
+              Call CreerMsg(1, IDSuivi)
+            Else
+              Debug.Print rsS![CodeAgent], rsS![moisRH], rsS![anneeRH]
+              errImport = True
+            End If
+           End If
+           rsS.MoveNext
+          Loop
+         If errImport = True Then erreurs = erreurs & "; " & "Possibles erreurs de traitement des données"
+          'on met une pause avant fermeture si des donénes ont été importées
+         pause = 1
+       End If
+       .txt_msg.Caption = msg1 & vbNewLine & msg2 & vbNewLine & vbNewLine & msg3
+    
+       If Left(erreurs, 2) = "; " Then erreurs = Right(erreurs, Len(erreurs) - 2)
+    
+       If erreurs <> "" Then erreurs = erreurs & vbNewLine
+       erreurs = VerificationComplete & erreurs
+    
+       If Len(erreurs) > 0 Then
+        pause = 1
+        .erreurs.Visible = True
+        .erreurs.Locked = False
+        .erreurs = erreurs
+        .erreurs.Locked = True
+        .Refresh
+       End If
+    
+      End If
+    
+     'fin du chargement
+     If pause = 0 And Bloque = 0 Then
+      ' RAS: on passe à la suite
+      Call Attendre(200)
+      DoCmd.Close acForm, frm.Name
+      If CurrentProject.AllForms("frm_Menu").IsLoaded = False Then DoCmd.OpenForm "frm_menu"
+      DoEvents
+     ElseIf pause = 1 And Bloque = 0 Then
+      'infos: il faut appuyer sur une touche pour continuer
+      .Continuer.Visible = True
+      If CurrentProject.AllForms("frm_Menu").IsLoaded = True Then forms![frm_menu].Refresh
+     Else
+      'erreur, on quitte si ce n'est pas un admin
+      If acces(CurrentUser) <> 2 Then
+       .Bloque = True
+       .Quitter.Visible = True
+      Else
+       .Bloque = False
+       .Continuer.Visible = True
+      End If
+     End If
+End With
+
+'SysCmd acSysCmdSetStatus, "AGRHum"
+
+Call SysCmd(5)
+
+End Function
+
+Public Function VerificationVersion()
+
+'Verification de la version installée
+'la fonction compare la date de version stockée dans tbl_parametre (locale) et celle stockée dans ztblVersion (réseau)
+    Dim version_locale As String
+    Dim version_reseau As String
+    
+    version_locale = DLookup("Valeur", "[tbl_parametre]", "[Parametre]='VERSION'")
+    version_reseau = DMax("VERSION", "[ztblVersion]", "")
+    
+    If version_locale <> version_reseau Then
+     If (DCount("valeur", "tbl_parametre", "parametre='ADMIN' AND valeur='" & CurrentUser & "'") > 0) Then
+      VerificationVersion = -1
+      'MsgBox "Attention, l'application n'est peut-être pas à jour (cf. [tbl_parametre] et [ztblVersion])"
+     Else
+      'MsgBox "Attention, votre version de l'application n'est pas à jour. Veuillez contacter Jacky Klein ou Olivier Massot."
+      VerificationVersion = -1
+      'Application.Quit
+     End If
+     Exit Function
+    End If
+    
+    VerificationVersion = 1
+    
+End Function
+
+Public Function VerifVersionPDA()
+'Verification de la version PDA installée
+'la fonction compare le numéro de version stocké dans tbl_parametre (locale) et celle stockée dans VerifVersionPDA_RH (réseau)
+    Dim version_locale As String
+    Dim version_reseau As String
+    
+    version_locale = DLookup("Valeur", "[tbl_parametre]", "[Parametre]='VersionPDA'")
+    version_reseau = DMax("VerifVersion", "[VerifVersionPDA_RH]", "")
+
+    If version_locale > version_reseau Then
+     If (DCount("valeur", "tbl_parametre", "parametre='ADMIN' AND valeur='" & CurrentUser & "'") > 0) Then
+      VerifVersionPDA = -1
+      'MsgBox "Attention, l'application PDA n'est peut-être pas à jour (cf. [tbl_parametre] et [ztblVersion])"
+     Else
+      'MsgBox "Attention, votre version de l'application PDA n'est pas à jour. Veuillez contacter Jacky Klein ou Olivier Massot."
+      VerifVersionPDA = -1
+     End If
+     Exit Function
+    End If
+    
+    VerifVersionPDA = 1
+
+End Function
+
+Public Function ajoutSuivi(ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer) As Integer
+'On Error GoTo err
+Dim sql As String
+
+'creation de la nouvelle ligne de suivi
+sql = "INSERT INTO tbl_SuiviRH ( CodeAgent, MoisRH, AnneeRH, Etat, Valide ) " & _
+      "SELECT '" & CodeAgent & "' AS Expr1, " & moisRH & " AS Expr2, " & anneeRH & " AS Expr3, 'Importé' AS Expr4, True AS Expr5;"
+
+DoCmd.SetWarnings False
+  DoCmd.RunSQL sql
+DoCmd.SetWarnings True
+
+DoEvents
+
+critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+ajoutSuivi = Nz(DLookup("IDSuivi", "tbl_SuiviRH", critere), -1)
+
+Exit Function
+err:
+ajoutSuivi = -1
+End Function

test/source/modules/CtrlLiens.bas

@@ -0,0 +1,184 @@
+Option Compare Database
+
+'Option Explicit
+Dim i As Long
+Dim db As DAO.Database
+Dim rs As DAO.Recordset
+Dim Tbl As TableDef
+Dim chemin As String
+Dim Connection(20), ConnectionGood(20) As String
+Dim iMax As Byte
+
+Public strFiltre As String
+Public strFile As String
+Public strNomFile As String
+Public RetVal As Long
+
+Public Function Controler_Liens() 'Fonction de contrôle des liens
+Dim ConnectOK As Boolean
+Dim Phrase, nomFichier As String
+Dim j As Byte
+iMax = 0
+DoCmd.OpenForm "frm_TablesAttachees", acNormal, , , , acWindowNormal
+On Error Resume Next
+ Set db = CurrentDb()
+ For i = 0 To db.TableDefs.Count - 1
+  Set Tbl = db.TableDefs(i)
+  If (Left(Tbl.Name, 4) <> "Msys") And (Tbl.Attributes = dbAttachedTable) Then
+   Message "Table : " & Tbl.Name & "..."
+   Set rs = db.OpenRecordset(Tbl.Name)
+   DoEvents
+     err.Clear
+     j = 0
+     ConnectOK = False
+     'Cherche le nom de la base à connecter
+     nomFichier = ExtraitNomFichier(ExtraitNomDb(Tbl.Connect))
+     If IsNull(DLookup("valeur", "tbl_parametre", "parametre='" & nomFichier & "'")) Then
+        MsgBox "Attention, Problème de définition des paramètres pour la base " & nomFichier & ", Vérifier tbl_parametre et recommencez"
+        Sclose
+        DoCmd.Close acForm, "TablesAttachees"
+        Exit Function
+    End If
+    'Cherche l'adresse de la base dans les parametres
+     nomFichier = DLookup("valeur", "tbl_parametre", "parametre='" & nomFichier & "'") & nomFichier
+     'Lie à cette base
+     If TestExisteFichier(nomFichier) Then
+        nomFichier = ";DATABASE=" & nomFichier & ";UID="""";PWD="""""
+        Rafraichir_Liens Tbl.Name, nomFichier
+        ConnectOK = True
+     End If
+     'Sinon recherche manuellement
+     If Not ConnectOK Then
+        Phrase = "La table " & Tbl.Name & " ne peut plus être liée à la base " & ExtraitNomDb(Tbl.Connect) & vbNewLine _
+            & "La manipulation est stoppée, Vérifiez vos paramètres et recommencez..."
+       MsgBox Phrase, , "Tables attachée en erreur"
+       Sclose
+        DoCmd.Close acForm, "frm_TablesAttachees"
+        Exit Function
+     End If
+   End If
+  rs.Close
+ ' End If
+ Next i
+ Sclose
+ DoCmd.Close acForm, "frm_TablesAttachees"
+End Function
+
+Private Sub Sclose()
+ db.Close
+ Set rs = Nothing
+ Set Tbl = Nothing
+ Set db = Nothing
+End Sub
+
+Private Sub Rafraichir_Liens(TableName As String, CheminConnu As String, Optional AncienChemin As String)  'Sub pour rétablir les liens des tables entre les 2 bases
+Dim i2 As Long
+On Error GoTo Err_Rafraichir_Liens
+ If CheminConnu = "" Then
+    chemin = OpenFile("Recherche de la base " & ExtraitNomFichier(ExtraitNomDb(AncienChemin)), , True)
+    ConnectionGood(iMax - 1) = ";DATABASE=" & chemin & ";UID="""";PWD="""""
+ Else
+    chemin = CheminConnu
+ End If
+ 
+ For i2 = 0 To db.TableDefs.Count - 1
+  Set Tbl = db.TableDefs(i2)
+   If Tbl.Name = TableName Then
+    If CheminConnu = "" Then
+        Tbl.Connect = ";DATABASE=" & chemin & ";UID="""";PWD="""""
+    Else
+        Tbl.Connect = CheminConnu
+    End If
+    Tbl.RefreshLink
+   End If
+ Next i2
+ Message "Lien de la table " & TableName & " réparé."
+ Exit Sub
+Err_Rafraichir_Liens:
+ MsgBox "La Table " & Tbl.Name & " liée à votre base principale " & _
+         ExtraitNomDb(chemin) & " ne peut pas être réparée.", vbCritical
+ Message "La Table " & Tbl.Name & " -> " & ExtraitNomDb(AncienChemin) & " n'est pas plus attachée."
+ err.Clear
+End Sub
+Private Sub Message(texte As String)
+forms("frm_TablesAttachees").tbMessage = forms("frm_TablesAttachees").tbMessage & texte & vbNewLine
+End Sub
+
+
+Public Function TestExisteFichier(Path As String) As Boolean
+ If dir(Path) = "" Then
+     TestExisteFichier = False
+ Else
+     TestExisteFichier = True
+ End If
+End Function
+
+
+
+Function ExtraitNomDb(strNomConnect As String) As String
+Dim i As Long
+i = InStr(11, strNomConnect, ";")
+ExtraitNomDb = Mid(strNomConnect, 11, Len(strNomConnect) - i + 12)
+End Function
+
+'Renvoi le nom du répertoire de la base de données
+Function fCurrentDBDir() As String
+
+Dim strDBPath As String
+Dim strDBFile As String
+
+strDBPath = CurrentDb.Name
+strDBFile = dir(strDBPath)
+fCurrentDBDir = Left(strDBPath, Len(strDBPath) - Len(strDBFile))
+
+End Function
+
+
+Public Function OpenFile(Optional strTitle As Variant, _
+                         Optional strInitialDir As Variant, _
+                         Optional MultiSelect As Boolean = False) As String
+
+If IsMissing(strTitle) Then
+strTitle = "Ouvrir..."
+End If
+
+If IsMissing(strInitialDir) Then
+    strInitialDir = CurDir
+End If
+
+OpenFile = ""
+strFiltre = "Fichiers Access" & Chr$(0) & "*.mdb"
+
+With Dialogue
+    .lStructSize = Len(Dialogue)
+    .lpstrFilter = strFiltre
+    .lpstrFile = Space(254)
+    .nMaxFile = 255
+    .lpstrFileTitle = Space(254)
+    .nMaxFileTitle = 255
+    .lpstrInitialDir = strInitialDir
+    .lpstrTitle = strTitle
+  If MultiSelect = False Then
+    .flags = OFN_FileMustExist + _
+             OFN_HideReadOnly + _
+             OFN_PathMustExist
+  Else
+    .flags = OFN_FileMustExist + _
+             OFN_HideReadOnly + _
+             OFN_PathMustExist + _
+             OFN_AllowMultiSelect + _
+             OFN_LongNames + _
+             OFN_EXPLORER
+  End If
+End With
+
+'RetVal = GetOpenFileName(Dialogue)
+
+'If RetVal >= 1 Then
+'    OpenFile = fMultiSelect(Dialogue.lpstrFile)
+'Else
+'    OpenFile = ""
+'    Exit Function
+'End If
+
+End Function

test/source/modules/FctContrôle.bas

@@ -0,0 +1,647 @@
+Option Compare Database
+'fonctions de contrôle du bon fonctionnement de l'appli
+
+
+Public Function connexion()
+'connexion de l'utilisateur
+Dim val As Integer
+Dim login, sql, VERSION As String
+
+login = CurrentUser
+val = acces(login)
+VERSION = parametre("VERSION")
+
+'maj des infos dans ztblUtilisateur, et dans tbl_paramutil si besoin
+If val > 0 Then
+  'utilisateur reconnu: on met à jour ses infos
+  sql = "UPDATE ztblUtilisateurs SET ztblUtilisateurs.VersionAppli = '" & VERSION & "', ztblUtilisateurs.DerniereConnexion = '" & Date & "' " & _
+        "WHERE (((ztblUtilisateurs.login)='" & login & "'));"
+  connexion = 1
+Else
+  'nouvel utilisateur
+  sql = "INSERT INTO ztblUtilisateurs ( login, acces, VersionAppli, DerniereConnexion ) " & _
+        "SELECT '" & login & "' AS Expr1, 'consult' AS Expr2, '" & VERSION & "' AS Expr3, '" & Date & "' AS Expr4;"
+  Call PremCo(login)
+  connexion = 0
+End If
+
+DoCmd.SetWarnings False
+ DoCmd.RunSQL sql
+DoCmd.SetWarnings True
+
+End Function
+
+Sub PremCo(ByVal login As String)
+Dim sql, impr As String
+ DoCmd.SetWarnings False
+'ajout des lignes dans paramètres utilisateur
+ sql = "INSERT INTO tbl_ParamUtil ( Parametre, Description, [User] ) " & _
+     "SELECT tbl_ParamUtil.Parametre, First(tbl_ParamUtil.Description) AS PremierDeDescription, '" & login & "' AS Expr1 " & _
+     "From tbl_ParamUtil " & _
+     "GROUP BY tbl_ParamUtil.Parametre;"
+  DoCmd.RunSQL sql
+  
+'choix de l'imprimante
+ impr = NomImpr(True)
+ sql = "UPDATE tbl_ParamUtil SET tbl_ParamUtil.Valeur = '" & impr & "' " & _
+       "WHERE (((tbl_ParamUtil.Parametre)='Imprimante') AND ((tbl_ParamUtil.User)='" & login & "'));"
+ DoCmd.RunSQL sql
+ 
+ DoCmd.SetWarnings True
+
+End Sub
+
+
+
+Public Function VerifEtat(Tbl As String, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer, avertissement As Integer)
+Dim critere, msg As String
+'vérification des données stockées davant la création d'un formulaire
+'si données non validées, suppression, sinon, invalidation
+
+'avertissement: si 0, pas de message d'vartissement avant execution des requêtes; si 1: avertissement
+critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+VerifEtat = 0
+
+If Nz(DCount("[IDSuivi]", Tbl, critere), 0) >= 1 Then
+  If DLookup("[Etat]", "tbl_SuiviRH", critere) = "Importé" Then
+   'msg = "Voulez vous mettre à jour les données déjà enregistrées dans la table [" & Tbl & "]?"
+  Else
+   If acces(CurrentUser) = 2 Then
+    msg = "[ADMIN] Ce formulaire a déja été validé/édité. Voulez vous vraiment recréer les formulaires?"
+   Else
+    MsgBox "Ces données ont déja été validées. Veuillez contacter un administrateur."
+    VerifEtat = -1
+    Exit Function
+   End If
+  End If
+  
+  If Len(msg) > 0 Then
+    If MsgBox(msg, vbYesNo, Tbl) = vbNo Then
+     VerifEtat = -1
+     Exit Function
+    End If
+  End If
+  Call suppression(Tbl, CodeAgent, moisRH, anneeRH, avertissement)
+End If
+
+
+End Function
+
+
+Public Sub ControleMenu()
+Dim critere As String
+'contrôle l'affichage du menu en fonction de l'état des données
+
+CodeAgent = forms![frm_menu].lst_agent.Column(0)
+moisRH = forms![frm_menu].lst_mois.Column(0)
+anneeRH = forms![frm_menu].lst_annee.Column(0)
+
+If anneeRH > 2000 And moisRH <= 12 And moisRH > 0 Then
+
+ critere = "[Valide]=True AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+ If Not Nz(DCount("[IDSuivi]", "tbl_SuiviRH", critere), 0) >= 1 Then
+  VerrouMenu (1)
+ End If
+
+  If CodeAgent <> "" Then
+   critere = "[Valide]=True AND [CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+    If Nz(DCount("[IDSuivi]", "tbl_SuiviRH", critere), 0) = 1 Then
+      'fichier importé
+      If DLookup("[Etat]", "tbl_SuiviRH", critere) = "Importé" Or DLookup("[Etat]", "tbl_SuiviRH", critere) = "Invalidé" Then
+       If DCount("[IDSuivi]", "tbl_FormHS", critere) > 0 And DCount("[IDSuivi]", "tbl_FormDep", critere) > 0 Then
+       'données importées et analysées
+        'vérif:
+        If VerifCompteLignes(CodeAgent, moisRH, anneeRH) = 1 Then
+        'apparemment pas d'erreur d'analyse
+         VerrouMenu (3)
+        Else
+         MsgBox "Attention: il est possible que des erreurs se soient produites lors de l'analyse des données. Il est conseillé de remettre à jour les données."
+         VerrouMenu (3)
+        End If
+       Else
+        'données importées pas analysées
+         VerrouMenu (2)
+       End If
+     
+      ElseIf DLookup("[Etat]", "tbl_SuiviRH", critere) = "Validé" Then
+      'validé ou edité
+       VerrouMenu (4)
+        If DLookup("[Edite]", "tbl_SuiviRH", critere) = True Then
+         forms![frm_menu].Edition.Caption = "Edité le " & DLookup("[DateEdition]", "tbl_SuiviRH", critere)
+         forms![frm_menu].Edition.Visible = True
+        End If
+      End If
+     ElseIf Nz(DCount("[IDSuivi]", "tbl_SuiviRH", critere), 0) > 1 Then
+      'erreur de suivi
+      MsgBox "Attention: plusieurs lignes sont considérées comme valides dans la table de suivi pour cet agent et cette période."
+      VerrouMenu (1)
+     Else
+      'les données n'ont pas été importées
+      VerrouMenu (1)
+     End If
+  Else
+     If Nz(DCount("[IDSuivi]", "tbl_SuiviRH", critere), 0) >= 1 Then
+      VerrouMenu (6)
+     Else
+      VerrouMenu (5)
+     End If
+  End If
+Else
+ VerrouMenu (0)
+End If
+
+End Sub
+
+Public Function VerifCompteLignes(ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+Dim critere As String
+
+critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+If DCount("[DateRH]", "r_NbJoursImport", critere) = DCount("[IDSuivi]", "tbl_FormHS", critere) And DCount("[DateRH]", "r_NbJoursImport", critere) = DCount("[IDSuivi]", "tbl_FormDep", critere) Then
+VerifCompteLignes = 1 'ok
+Else
+VerifCompteLignes = 0  'erreur
+End If
+
+End Function
+
+Public Function PeriodeAgent(CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+'retourne le code de la période de validité correspondante à l'agent pour le mois et l'année indiqués
+'renvoie 0 si code non trouvé
+
+
+'Si le mois et/ou l'année entrés en paramètres sont à 0, on prend les valeurs du formulaire menu
+
+Dim rs As DAO.Recordset
+Dim critere As String
+Dim DateRH As Date
+
+If CurrentProject.AllForms("frm_Menu").IsLoaded Then
+  If moisRH = 0 Then moisRH = CInt(forms![frm_menu].[mois])
+  If anneeRH = 0 Then anneeRH = CInt(forms![frm_menu].[Annee])
+'ElseIf CurrentProject.AllForms("frm_chargement").IsLoaded Then
+'  If moisRH = 0 Then moisRH = CInt(Forms![frm_chargement].[mois])
+'  If anneeRH = 0 Then anneeRH = CInt(Forms![frm_chargement].[Annee])
+Else
+  PeriodeAgent = 0
+  Exit Function
+End If
+
+critere = "[CodeAgent]='" & CodeAgent & "'"
+DateRH = CDate("15/" & moisRH & "/" & anneeRH)
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_PeriodeAgent WHERE " & critere & ";")
+'Debug.Print "SELECT * FROM tbl_PeriodeAgent WHERE " & critere & ";"
+If Not rs.RecordCount > 0 Then
+ PeriodeAgent = 0
+ Exit Function
+End If
+
+rs.MoveFirst
+Do Until DateRH >= rs![DateInf] And (DateRH <= rs![DateSup] Or IsNull(rs![DateSup]))
+rs.MoveNext
+ If rs.EOF = True Then
+  PeriodeAgent = 0
+  Exit Function
+ End If
+Loop
+
+PeriodeAgent = CInt(rs![CodePeriode])
+
+End Function
+
+Public Function PeriodeBareme(NomBareme As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+'retourne le code de la période de validité correspondante au barême pour le mois et l'année indiqués
+'renvoie 0 si code non trouvé
+'si le mois et l'année entrés en paramètres sont égaux à 0, on prend ceux du menu
+
+Dim rs As DAO.Recordset
+Dim critere As String
+Dim DateRH As Date
+
+If CurrentProject.AllForms("frm_Menu").IsLoaded Then
+  If moisRH = 0 Then moisRH = CInt(forms![frm_menu].[mois])
+  If anneeRH = 0 Then anneeRH = CInt(forms![frm_menu].[Annee])
+ElseIf CurrentProject.AllForms("frm_chargement").IsLoaded Then
+  If moisRH = 0 Then moisRH = CInt(forms![frm_chargement].[mois])
+  If anneeRH = 0 Then anneeRH = CInt(forms![frm_chargement].[Annee])
+Else
+  PeriodeBareme = 0
+  Exit Function
+End If
+
+'MsgBox "periode bareme: " & moisRH & "/" & anneeRH
+
+critere = "[NomBareme]='" & NomBareme & "'"
+DateRH = CDate("15/" & moisRH & "/" & anneeRH)
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_PeriodeBareme WHERE " & critere & ";")
+
+
+If Not rs.RecordCount > 0 Then
+ PeriodeBareme = 0
+ Exit Function
+End If
+
+rs.MoveFirst
+Do Until DateRH >= rs![DateInf] And (DateRH <= rs![DateSup] Or IsNull(rs![DateSup]))
+rs.MoveNext
+ If rs.EOF = True Then
+  PeriodeBareme = 0
+  Exit Function
+ End If
+Loop
+
+PeriodeBareme = rs![CodePeriode]
+
+End Function
+
+Public Function CtrlValidite(ByVal table As String, ByVal Champ1_valeur As String, ByVal NvelleDateInf As Date)
+'cette fonction vérifie que la nouvelle période n'entre pas en conflit avec une autre période
+'elle est utilisée au sein de la fonction NvellePeriode
+Dim rs As DAO.Recordset
+Dim sql, champ1_nom As String
+
+Set rs = CurrentDb.OpenRecordset(table)
+champ1_nom = rs.Fields(0).Name
+Set rs = Nothing
+
+sql = "SELECT * FROM " & table & " WHERE [" & table & "].[" & champ1_nom & "]='" & Champ1_valeur & "' ORDER BY [DateInf];"
+Set rs = CurrentDb.OpenRecordset(sql)
+
+'si pas d'autres périodes
+If rs.RecordCount = 0 Then Exit Function
+
+
+rs.MoveFirst
+Do Until rs.EOF = True
+  If Not IsNull(rs![DateSup]) = True Then
+    If NvelleDateInf <= rs![DateSup] And NvelleDateInf >= rs![DateInf] Then
+      ' la nouvelle date est comprise dans une période déja existante, la fonction renvoie le code de cette période
+      CtrlValidite = rs![CodePeriode]
+      Exit Function
+    End If
+  End If
+rs.MoveNext
+Loop
+
+'la nouvelle date n'est pas comprise dans une période existante, mais elle peut être antérieure
+' à une période existante, auquelle cas la date de fin devra être automatiquement remplie
+
+rs.MoveFirst
+Do Until rs.EOF = True
+  If Not IsNull(rs![DateSup]) = True Then
+    If NvelleDateInf <= rs![DateInf] Then
+      'la fonction renvoie le code de cette période en négatif
+      CtrlValidite = -1 * rs![CodePeriode]
+      Exit Function
+    End If
+  End If
+rs.MoveNext
+Loop
+
+
+CtrlValidite = 0
+End Function
+
+Function CtrlBareme(NomBareme As String, PeriodeValidite As Integer)
+Dim rs As DAO.Recordset
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_Periodebareme WHERE [NomBareme]='" & NomBareme & "' AND [PeriodeValidite]=" & PeriodeValidite)
+
+End Function
+
+Public Function VerifPeriodeAgent(CodeAgent As String)
+'cette fonction vérifie la cohérence des périodes affectées aux données de l'agent
+'elle renvoie une chaine de caractères constituée du code de l'agent et de chaque date manquante dans la table des périodes
+
+Dim rs As DAO.Recordset
+Dim sql As String
+Dim pbm As String
+Dim dat As Date
+Dim i, k As Integer
+
+sql = "SELECT tbl_PeriodeAgent.CodeAgent, tbl_PeriodeAgent.DateInf, tbl_PeriodeAgent.DateSup, tbl_PeriodeAgent.CodePeriode " & _
+      "FROM tbl_PeriodeAgent " & _
+      "WHERE (((tbl_PeriodeAgent.CodeAgent)='" & CodeAgent & "')) " & _
+      "ORDER BY tbl_PeriodeAgent.DateInf;"
+
+Set rs = CurrentDb.OpenRecordset(sql)
+If Not rs.RecordCount > 0 Then
+VerifPeriodeAgent = CodeAgent & ";" & "Tout"
+Exit Function
+End If
+
+dat = #1/1/2013# 'attention: format mois/jour/annee
+pbm = ""
+
+Do Until dat >= Date
+Ok = 0
+ rs.MoveFirst
+ Do Until rs.EOF = True
+   If dat <= Nz(rs![DateSup], Date) And dat >= rs![DateInf] Then Ok = 1
+  rs.MoveNext
+ Loop
+
+ If Ok = 0 Then
+ k = 0
+  For i = 0 To UBound(Split(pbm, ";"))
+   If Split(pbm, ";")(i) = Month(dat) & "/" & Year(dat) Then k = 1
+  Next i
+ If k = 0 Then pbm = pbm & Month(dat) & "/" & Year(dat) & ";"   'on évite les doublons
+ End If
+dat = dat + 1
+Loop
+
+If pbm <> "" Then
+pbm = CodeAgent & ";" & pbm
+pbm = Left(pbm, Len(pbm) - 1)
+End If
+rs.Close
+Set rs = Nothing
+VerifPeriodeAgent = pbm
+
+End Function
+
+Public Function VerifPeriodeBareme(NomBareme As String)
+'cette fonction vérifie la cohérence des périodes affectées aux baremes
+'elle renvoie une chaine de caractères constituée du nom du bareme et de chaque date manquante dans la table des périodes
+
+Dim rs As DAO.Recordset
+Dim sql As String
+Dim pbm As String
+Dim dat As Date
+Dim i, k As Integer
+
+sql = "SELECT tbl_PeriodeBareme.NomBareme, tbl_PeriodeBareme.DateInf, tbl_PeriodeBareme.DateSup " & _
+      "FROM tbl_PeriodeBareme " & _
+      "WHERE (((tbl_PeriodeBareme.NomBareme)='" & NomBareme & "')) " & _
+      "ORDER BY tbl_PeriodeBareme.DateInf;"
+
+Set rs = CurrentDb.OpenRecordset(sql)
+
+If Not rs.RecordCount > 0 Then
+VerifPeriodeBareme = NomBareme & ";" & "Tout"
+Exit Function
+End If
+
+dat = #1/1/2013# 'attention: format mois/jour/annee
+pbm = ""
+
+Do Until dat >= Date
+Ok = 0
+ rs.MoveFirst
+ Do Until rs.EOF = True
+   If dat <= Nz(rs![DateSup], Date) And dat >= rs![DateInf] Then Ok = 1
+  rs.MoveNext
+ Loop
+
+ If Ok = 0 Then
+ k = 0
+  For i = 0 To UBound(Split(pbm, ";"))
+   If Split(pbm, ";")(i) = Month(dat) & "/" & Year(dat) Then k = 1
+  Next i
+ If k = 0 Then pbm = pbm & Month(dat) & "/" & Year(dat) & ";"   'on évite les doublons
+ End If
+ 
+dat = dat + 1
+Loop
+
+If pbm <> "" Then
+pbm = NomBareme & ";" & pbm
+pbm = Left(pbm, Len(pbm) - 1)
+End If
+rs.Close
+Set rs = Nothing
+VerifPeriodeBareme = pbm
+
+End Function
+
+Public Function VerificationComplete()
+'lance les différentes fonctions de vérification et remplit éventuellement la table tmp_problemes
+Dim rs1, rs_pbm As DAO.Recordset
+Dim tmp, ErreurPeriode, ErreurDonnees As String
+Dim i As Integer
+
+'vidage de la table tmp_problemes
+DoCmd.SetWarnings False
+DoCmd.RunSQL "DELETE * FROM tmp_problemes;"
+DoCmd.SetWarnings True
+
+ErreurPeriode = ""
+ErreurDonnees = ""
+Set rs_pbm = CurrentDb.OpenRecordset("tmp_problemes")
+
+
+'Verification des périodes:
+
+Set rs1 = CurrentDb.OpenRecordset("SELECT tbl_Agents.CodeAgent FROM tbl_Agents GROUP BY tbl_Agents.CodeAgent;")
+rs1.MoveFirst
+Do Until rs1.EOF = True
+tmp = VerifPeriodeAgent(rs1![CodeAgent])
+ If tmp <> "" Then
+  For i = 1 To UBound(Split(tmp, ";"))
+   rs_pbm.AddNew
+    rs_pbm![ObjetConcerne] = Split(tmp, ";")(0)
+    rs_pbm![erreur] = "Date(s) Manquantes(s) pour la gestion des périodes des données agent"
+    rs_pbm![Detail] = Split(tmp, ";")(i)
+   rs_pbm.Update
+  Next i
+ ErreurPeriode = "Erreurs détectées dans le paramétrage des périodes (cf. tmp_problemes)"
+ End If
+ rs1.MoveNext
+Loop
+rs1.Close
+
+Set rs1 = CurrentDb.OpenRecordset("SELECT tbl_baremes.NomBareme FROM tbl_baremes GROUP BY tbl_baremes.NomBareme;")
+rs1.MoveFirst
+Do Until rs1.EOF = True
+tmp = VerifPeriodeBareme(rs1![NomBareme])
+ If tmp <> "" Then
+  For i = 1 To UBound(Split(tmp, ";"))
+   rs_pbm.AddNew
+    rs_pbm![ObjetConcerne] = Split(tmp, ";")(0)
+    rs_pbm![erreur] = "Date(s) Manquantes(s) pour la gestion des périodes du bareme"
+    rs_pbm![Detail] = Split(tmp, ";")(i)
+   rs_pbm.Update
+  Next i
+ ErreurPeriode = "Erreurs détectées dans le paramétrage des périodes (cf. tmp_problemes)"
+ End If
+ rs1.MoveNext
+Loop
+rs1.Close
+
+
+'vérification de la cohérence des données des tables
+
+ tmp = VerifTables()
+  If tmp <> "" Then
+   For i = 1 To UBound(Split(tmp, ";"))
+    rs_pbm.AddNew
+     rs_pbm![ObjetConcerne] = Split(tmp, ";")(0)
+     rs_pbm![erreur] = "Données incohérentes/manquantes"
+     rs_pbm![Detail] = Split(tmp, ";")(i)
+    rs_pbm.Update
+   Next i
+  ErreurDonnees = "Erreurs détectées dans la cohérence des données des tables (cf. tmp_problemes)"
+  End If
+
+
+
+If rs_pbm.RecordCount > 0 Then
+End If
+
+If Len(ErreurPeriode) > 0 Or Len(ErreurDonnees) > 0 Then
+ VerificationComplete = ErreurPeriode & vbNewLine & ErreurDonnees
+Else
+ VerificationComplete = ""
+End If
+
+End Function
+
+Public Function VerifTables()
+'vérification de la cohérence des données des tables
+Dim pbm As String
+Dim rs As DAO.Recordset
+Dim i As Integer
+
+pbm = ""
+
+'tbl_agents
+
+Set rs = CurrentDb.OpenRecordset("SELECT tbl_Agents.CodeAgent, tbl_Agents.TypeVehicule, tbl_Agents.DateAutorisationVP, tbl_Agents.PuissanceFiscVP, tbl_Agents.NbKmAutorisesVP " & _
+                                 "FROM tbl_Agents " & _
+                                 "WHERE ((tbl_Agents.TypeVehicule)<>'4') AND ((((tbl_Agents.TypeVehicule) Is Not Null)) OR (((tbl_Agents.DateAutorisationVP) Is Not Null)) OR (((tbl_Agents.PuissanceFiscVP) Is Not Null)) OR (((tbl_Agents.NbKmAutorisesVP) Is Not Null)));")
+rs.MoveFirst
+Do Until rs.EOF = True
+ 'verif des données véhicules
+ For i = 1 To rs.Fields.Count - 1
+  If IsNull(rs.Fields(i).Value) Then pbm = pbm & ";Agent " & rs![CodeAgent] & ": champ manquant [" & rs.Fields(i).Name & "]"
+ Next
+rs.MoveNext
+Loop
+
+If Left(pbm, 1) = ";" Then pbm = Right(pbm, Len(pbm) - 1)
+If pbm <> "" Then pbm = "tbl_Agents;" & pbm
+VerifTables = pbm
+
+End Function
+
+Public Function VerifRepas(CodeAgent As String, DateRH As Date)
+ 'vérification des données à l'import: un agent n'a le droit qu'à un repas par jour
+  '0 -> ok ; -1 -> non
+ VerifRepas = -1
+ If Nz(DSum("repas", "tbl_ImportRH", "[CodeAgent]='" & CodeAgent & "' and [DateRH]=#" & Format(DateRH, "mm-dd-yyyy") & "#"), 0) > 1 Then VerifRepas = 0
+
+End Function
+
+Public Function VerifDroit(ByVal IdImportRH As Long)
+ 'vérification des données à l'import: un agent n'a le droit à des frais que s'il s'est rendu ailleurs que sur sa residence admin
+  '1 -> a le droit ; 0 -> pas le droit, mais pas de données ; -1 pas le droit et des données
+ Dim ResAdm As String
+ Dim rs As DAO.Recordset
+ Dim sortie As Integer
+ 'attention aux périodes de validité des données
+
+ ResAdm = Nz(DLookup("ResidenceAdmin", "tbl_Agents", "[CodeAgent]='" & CodeAgent & "' AND [PeriodeValidite]=" & PeriodeAgent(CodeAgent, Month(DateRH), Year(DateRH))), "")
+ VerifDroit = 0
+ If Len(ResAdm) = 0 Then Exit Function
+
+ sortie = 0
+
+ Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_ImportRH WHERE [CodeAgent]='" & CodeAgent & "' AND [DateRH]=#" & Format(DateRH, "mm-dd-yyyy") & "#;")
+ 'Debug.Print "SELECT * FROM tbl_ImportRH WHERE [CodeAgent]='" & CodeAgent & "' AND [DateRH]=#" & Format(DateRH, "mm-dd-yyyy") & "#;"
+ If Not rs.RecordCount > 0 Then Exit Function
+ rs.MoveFirst
+ Do Until rs.EOF = True
+  If Not rs![Localisation] Like ResAdm Then sortie = sortie + 1
+ rs.MoveNext
+ Loop
+ 
+ If sortie = 0 Then
+   VerifDroit = 0
+   rs.MoveFirst
+   Do Until rs.EOF = True
+    If rs![Repas] > 0 Or rs![DistanceTranche1] > 0 Or rs![DistanceTranche2] > 0 Then VerifDroit = 0
+   rs.MoveNext
+   Loop
+ End If
+
+End Function
+
+Public Function VerifVP(CodeAgent As String, DateRH As Date)
+'On Error GoTo fin
+Dim sql As String
+
+ VerifVP = -1
+
+ sql = "SELECT tbl_ImportRH.IdImportRH, tbl_ImportRH.CodeAgent, tbl_ImportRH.DateRH, tbl_ImportRH.VehiculePersoTranche1, tbl_ImportRH.VehiculePersoTranche2, " & _
+       "tbl_Agents.TypeVehicule " & _
+       "FROM tbl_ImportRH INNER JOIN tbl_Agents ON tbl_ImportRH.CodeAgent = tbl_Agents.CodeAgent " & _
+       "WHERE (tbl_ImportRH.CodeAgent='" & CodeAgent & "' AND tbl_ImportRH.DateRH=#" & Format(DateRH, "mm-dd-yyyy") & "#) AND " & _
+       "(tbl_ImportRH.VehiculePersoTranche1='True' OR tbl_ImportRH.VehiculePersoTranche2='True') AND tbl_Agents.TypeVehicule='4';"
+ 'Debug.Print sql
+ Set rs = CurrentDb.OpenRecordset(sql)
+ If rs.RecordCount > 0 Then VerifVP = 0
+
+fin:
+On Error Resume Next
+rs.Close
+End Function
+
+Public Function VerifImport(CodeAgent As String, moisRH As Integer, anneeRH As Integer)
+On Error GoTo err
+'procède à l'examen des données brutes lors de l'import
+Dim rs As DAO.Recordset
+
+VerifImport = ""
+If Len(CodeAgent) = 0 Or Not moisRH > 0 Or Not moisRH < 13 Or Not anneeRH > 2000 Then Exit Function
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM r_DonneesImport WHERE [CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH & ";")
+If Not rs.RecordCount > 0 Then Exit Function
+
+rs.MoveFirst
+Do Until rs.EOF = True
+ If rs![FraisValide] = False Then
+  VerifImport = " -> DONNEES A VERIFIER"
+  Exit Function
+ End If
+rs.MoveNext
+Loop
+rs.Close
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM r_DonneesImport2 WHERE [CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH & ";")
+If Not rs.RecordCount > 0 Then Exit Function
+
+rs.MoveFirst
+Do Until rs.EOF = True
+ 'If VerifDroit(CodeAgent, rs![DateRH]) = -1 Or VerifRepas(CodeAgent, rs![DateRH]) = -1 Or VerifVP(CodeAgent, rs![DateRH]) = -1 Then
+ If VerifRepas(CodeAgent, rs![DateRH]) = 0 Or VerifVP(CodeAgent, rs![DateRH]) = 0 Then
+  VerifImport = " -> DONNEES A VERIFIER"
+  Exit Function
+ End If
+rs.MoveNext
+Loop
+rs.Close
+
+Exit Function
+err:
+VerifImport = "Impossible de vérifier les données"
+End Function
+
+Public Function VerifDonneesExport(ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer) As Boolean
+'procède à l'examen des données lors de l'export vers PERIPLE
+On Error GoTo fin
+VerifDonneesExport = True
+If Len(VerifImport(CodeAgent, moisRH, anneeRH)) > 0 Then VerifDonneesExport = False
+
+fin:
+On Error Resume Next
+Exit Function
+err:
+MsgBox "Des erreurs se sont produites lors de la vérification des données, veuillez contacter un administrateur"
+VerifDonneesExport = False
+GoTo fin
+End Function

test/source/modules/Internet.bas

@@ -0,0 +1,25 @@
+Option Compare Database
+
+Public Declare Function ShellExecute Lib "shell32.dll" _
+    Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
+    ByVal lpFile As String, ByVal lpParameters As String, _
+    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+
+Sub Internet(Adresse As String)
+    ShellExecute 0, "", Adresse, "", "", 0
+End Sub
+
+Public Function DistanceInternet(ByVal Depart As String, ByVal arrivee As String)
+Dim lien As String
+
+Depart = UCase(Left(Depart, 1)) & LCase(Right(Depart, Len(Depart) - 1))
+arrivee = UCase(Left(arrivee, 1)) & LCase(Right(arrivee, Len(arrivee) - 1))
+
+'lien = "http://fr.distancevilles.net/distance-" & depart & "-et-" & arrivee
+
+lien = "http://maps.google.fr/maps?saddr=" & Depart & "&daddr=" & arrivee
+
+Call Internet(lien)
+
+
+End Function

test/source/modules/Liens.bas

@@ -0,0 +1,54 @@
+Option Compare Database
+
+Public Function get_lien(ByVal Nom As String, Optional mode As String = "*") As String
+On Error GoTo err_lien
+Dim filtre As String
+ 
+    filtre = "[nom]='" & Nom & "' AND [mode] like '" & mode & "'"
+    'If Len(mode) > 0 Then filtre = filtre & " AND [mode] like '" & mode & "'"
+    
+    get_lien = DFirst("lien", "ztbl_liens", filtre)
+
+
+fin:
+    Exit Function
+err_lien:
+    If err.Number = 94 Then
+        MsgBox "Le lien vers '" & Nom & "' (mode '" & mode & "') n'existe pas dans ztbl_liens", vbCritical
+    Else
+        MsgBox "Impossible de trouver le lien '" & Nom & "' (mode '" & mode & "'):" & vbNewLine & err.Description, vbCritical
+    End If
+End Function
+
+
+'temp: pour trouver les logos
+Sub list_images()
+Dim str As String
+
+forms:
+For Each frm In Application.CurrentProject.AllForms
+    DoCmd.OpenForm frm.Name, acDesign, , , , acHidden
+    str = ""
+    For Each ctl In forms(frm.Name).Controls
+        If ctl.ControlType = acImage Then
+            str = str & ctl.Name & ",   "
+        End If
+    Next ctl
+    If Len(str) > 0 Then Debug.Print frm.Name, str
+    DoCmd.Close acForm, frm.Name, acSaveNo
+Next frm
+
+etats:
+For Each rpt In Application.CurrentProject.AllReports
+    DoCmd.OpenReport rpt.Name, acViewDesign, , , acHidden
+    str = ""
+    For Each ctl In Reports(rpt.Name).Controls
+        If ctl.ControlType = acImage Then
+            str = str & ctl.Name & ",   "
+        End If
+    Next ctl
+    If Len(str) > 0 Then Debug.Print rpt.Name, str
+    DoCmd.Close acReport, rpt.Name, acSaveNo
+Next rpt
+
+End Sub

test/source/modules/Mail.bas

@@ -0,0 +1,115 @@
+Option Compare Database
+
+Public Sub Mail_Maj()
+Dim VERSION, modif, lien As String
+Dim DateVersion As Date
+Dim sujet, str As String
+
+'avertissement
+lien = parametre("Lien_MAJ")
+If Not Len(lien) > 0 Then Exit Sub
+
+If MsgBox("ATTENTION:  Votre version de l'application n'est pas à jour. Voulez-vous qu'un mail de mise à jour vous soit envoyé?", vbYesNo) = vbNo Then Exit Sub
+
+sujet = "AUTOMATIQUE - Mise à jour " & CurrentDb.Properties("AppTitle")
+
+str = "<html>" & vbCrLf & _
+          "<body>" & vbCrLf & _
+             "Bonjour, <br><br>" & vbCrLf
+
+'version:
+DateVersion = DMax("Version", "ztblVersion", "")
+If DateVersion > #1/1/1990# Then VERSION = " en version: <b>" & Nz(DLookup("Version_Lb", "ztblVersion", "[Version]=#" & Format(DateVersion, "mm/dd/yyyy") & "#"), "") & " (" & DateVersion & ")</b><br>"
+If Not Len(VERSION) > 0 Then VERSION = " dans une nouvelle version."
+
+str = str & " L'application <b>" & CurrentDb.Properties("AppTitle") & "</b> est disponible " & VERSION & vbCrLf
+
+'modifs
+If DateVersion > #1/1/1990# Then modif = Nz(DLookup("Modifications", "ztblVersion", "[Version]=#" & Format(DateVersion, "mm/dd/yyyy") & "#"), "")
+If Len(modif) > 0 Then
+ str = str & _
+       " Les modifications suivantes ont été apportées: <br><br>" & vbCrLf & _
+       "  " & modif & "<br><br>" & vbCrLf
+End If
+
+'fin du message
+lien = "<a href='" & lien & "'>ici</a><br>"
+
+str = str & _
+             " Pour mettre à jour, cliquez " & lien & "<br>" & vbCrLf & _
+             "Bonne journée!" & vbCrLf & _
+          "</body>" & vbCrLf & _
+      "</html>"
+
+Call EnvoiMail(sujet, str, , True)
+'l'absence de destinataire défini enverra le mail à l'utilisateur (il se l'envoie à lui-même)
+
+MsgBox "Le mail a été envoyé, vous devriez le recevoir d'ici quelques instants."
+
+End Sub
+
+Public Sub EnvoiMail(ByVal sujet As String, ByVal texte As String, Optional dest As String, Optional EnvoiAuto As Boolean)
+'si le destinataire n'est pas precisé, le mail est envoyé à soi-même (pour un mail de MAJ par exemple)
+Dim olApp As Outlook.Application
+Dim objMail As Outlook.MailItem
+Dim oAccount As Outlook.Account
+
+Set olApp = GetObject("", "Outlook.Application")
+Dim olExplorer As Outlook.Explorer
+Dim html As Integer
+html = 0
+If Left(texte, 6) = "<html>" Then html = 1
+' Créons un objet Mail qui va nous servir de base pour définir les paramètres et le contenu de notre mail
+
+Set objMail = olApp.CreateItem(olMailItem)
+
+'Maintenant nous allons créer un object nous permettant de nous déplacer dans les dossiers d’outlook.
+Dim mpf As Outlook.MAPIFolder
+
+'Dans quel format voulons nous notre Mail Texte Brut ou Texte Enrichi
+If html = 1 Then
+objMail.BodyFormat = olFormatHTML
+Else
+objMail.BodyFormat = olFormatRichText
+End If
+
+'Affiche le mail dans Outlook
+'Sans cette ligne la fenêtre n’est pas visible
+If Nz(EnvoiAuto, False) = False Then objMail.Display
+
+'Affectation du sujet du mail
+'Idéalement, vous utiliserez dans votre propre code une variable ou un paramètre via l’appel de cette procédure
+objMail.Subject = sujet
+
+'Affectation du corps du message, le Body…
+
+If html = 1 Then
+objMail.HTMLBody = texte
+Else
+objMail.Body = texte
+End If
+
+'Affectation du destinataire du message
+
+If Not Len(dest) > 0 Then
+ For Each oAccount In olApp.Session.Accounts
+  dest = oAccount.SmtpAddress
+ Next
+End If
+
+objMail.To = dest
+
+'Affectation des destinataires en Copie ou en copie cachée
+'objMail.Cc = "-@cg67.fr"
+'objMail.BCC= "-@cg67.fr"
+
+' Et voila, vous avez prérempli votre mail au sein d’outlook
+' Il ne vous reste plus que de compléter éventuellement votre mail à la main et de cliquer sur Envoyer
+ 
+'Si vous souhaitez forcer l’envoi directement depuis le code VBA, sans laisser le temps à l’utilisateur de relire le mail
+' il vous suffit de faire appel à :
+If Nz(EnvoiAuto, False) = True Then objMail.Send
+
+Set olApp = Nothing
+Set objMail = Nothing
+End Sub

test/source/modules/Msg.bas

@@ -0,0 +1,166 @@
+Option Compare Database
+
+Sub testMSG()
+
+Call CreerMsg(12, , "T22")
+
+End Sub
+
+Public Function AfficherMsgProgression(titre As String, Optional ByVal msg As String)
+  DoCmd.Hourglass True
+  DoCmd.OpenForm "msg_traitement"
+  forms![msg_traitement].[txt_titre].Caption = titre
+  If Len(msg) > 0 Then
+    forms![msg_traitement].[txt_msg].Caption = msg
+  Else
+    forms![msg_traitement].[txt_msg].Visible = False
+  End If
+  'largeur_prog = 5137
+  forms![msg_traitement].prog.Width = 1
+End Function
+
+Public Function MajMsgProgression(prog As Integer, Total As Integer)
+  Dim taux As Single
+  If Total = 0 Then Exit Function
+  If CurrentProject.AllForms("msg_traitement").IsLoaded = False Then Exit Function
+  taux = prog / Total
+  forms![msg_traitement].prog.Width = 5137 * taux
+  If prog >= Total Then
+    DoCmd.Hourglass False
+    DoCmd.Close acForm, "msg_traitement"
+  End If
+End Function
+
+Public Function CreerMsg(code As Integer, Optional ByVal IDSuivi As Double, Optional ByVal AutreID As String, Optional ByVal val As String)
+'cette fonction renvoie les messages de suivi stockés dans la table tbl_msg
+
+'l'IDSuivi permet l'identification des lignes de tbl_SuiviRH
+'la variable AutreID représente le code d'un agent, le nom d'un barème, ou tout autre identifiant nécessaire à un message
+'la variable val fournit éventuellement une indication complémentaire
+
+Dim msg As String
+Dim rs As DAO.Recordset
+
+Select Case code
+
+Case 1
+'import
+ If Nz(IDSuivi, 0) > 0 Then
+  Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_SuiviRH WHERE [IDSuivi]=" & IDSuivi & ";")
+  
+  If rs.RecordCount = 0 Or rs.RecordCount > 1 Then
+   msg = "Nouvelles données importées"
+  Else
+  
+   msg = "Import des données de " & DLookup("Nom", "r_agents", "[CodeAgent]='" & rs![CodeAgent] & "'") & _
+         " pour le mois de " & MonthName(rs![moisRH]) & " " & rs![anneeRH]
+  End If
+ Else
+  msg = "Nouvelles données importées"
+ End If
+
+Case 2
+'validation
+ If Nz(IDSuivi, 0) > 0 Then
+  Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_SuiviRH WHERE [IDSuivi]=" & IDSuivi & ";")
+
+  If rs.RecordCount = 0 Or rs.RecordCount > 1 Then
+   msg = "Des données ont été validées"
+  Else
+  
+   msg = "Validation des données de " & DLookup("Nom", "r_agents", "[CodeAgent]='" & rs![CodeAgent] & "'") & _
+         " pour le mois de " & MonthName(rs![moisRH]) & " " & rs![anneeRH]
+  End If
+ Else
+  msg = "Des données ont été validées"
+ End If
+
+Case 3
+'re-traitement des données
+ If Nz(IDSuivi, 0) > 0 Then
+  Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_SuiviRH WHERE [IDSuivi]=" & IDSuivi & ";")
+  
+  If rs.RecordCount = 0 Or rs.RecordCount > 1 Then
+   msg = "Des données ont été réanalysées"
+  Else
+  
+   msg = "Ré-analyse des données de " & DLookup("Nom", "r_agents", "[CodeAgent]='" & rs![CodeAgent] & "'") & _
+         " pour le mois de " & MonthName(rs![moisRH]) & " " & rs![anneeRH]
+  End If
+ Else
+  msg = "Des données ont été réanalysées"
+ End If
+
+Case 4
+'formulaires edités
+ If Nz(IDSuivi, 0) > 0 Then
+  Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_SuiviRH WHERE [IDSuivi]=" & IDSuivi & ";")
+  
+  If rs.RecordCount = 0 Or rs.RecordCount > 1 Then
+   msg = "Formulaires edités"
+  Else
+  
+   msg = "Edition des formulaires de " & DLookup("Nom", "r_agents", "[CodeAgent]='" & rs![CodeAgent] & "'") & _
+         " pour le mois de " & MonthName(rs![moisRH]) & " " & rs![anneeRH]
+  End If
+ Else
+  msg = "Formulaires edités"
+ End If
+
+Case 11
+'barème mise à jour
+ If Len(Nz(AutreID, "")) > 0 Then
+  If Len(Nz(val, "")) > 0 Then
+   msg = "Le barème " & AutreID & " a été mis à jour (CodePeriode " & val & ")"
+  Else
+   msg = "Le barème " & AutreID & " a été mis à jour"
+  End If
+ Else
+  msg = "Un barème a été mis à jour"
+ End If
+
+Case 12
+'agent mis à jour
+ If Len(Nz(AutreID, "")) > 0 Then
+  If Len(Nz(val, "")) > 0 Then
+   msg = "Les données de l'agent " & DLookup("Nom", "r_agents", "[CodeAgent]='" & AutreID & "'") & " ont été mises à jour (CodePeriode " & val & ")"
+  Else
+   msg = "Les données de l'agent " & DLookup("Nom", "r_agents", "[CodeAgent]='" & AutreID & "'") & " ont été mises à jour"
+  End If
+ Else
+  msg = "Les données d'un agent ont été mises à jour"
+ End If
+
+Case 13
+'agent créé
+ If Len(Nz(AutreID, "")) > 0 Then
+  msg = "L'agent " & DLookup("Nom", "r_agents", "[CodeAgent]='" & AutreID & "'") & " a été créé ('" & AutreID & "')"
+ Else
+  msg = "Un agent a été créé"
+ End If
+
+Case 21
+'mise à jour de l'appli
+msg = "L'application a été mise à jour"
+
+End Select
+
+Call NveauMsg(msg)
+CreerMsg = msg
+
+End Function
+
+Public Sub NveauMsg(msg As String)
+Dim rs As DAO.Recordset
+
+Set rs = CurrentDb.OpenRecordset("tbl_msg")
+
+rs.AddNew
+rs![msg] = msg
+rs![DateMsg] = Now()
+rs![User] = Environ("username")
+rs.Update
+
+rs.Close
+
+End Sub

test/source/modules/TraitementDonnees.bas

@@ -0,0 +1,442 @@
+Option Compare Database
+
+Public Function suppression(Tbl As String, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer, avertissement As Integer)
+'ATTENTION: fonction à utiliser avec précaution (ajouter éventuellement une distinction entre valide et invalide)
+
+If avertissement = 0 Then DoCmd.SetWarnings False
+DoCmd.RunSQL "DELETE " & Tbl & ".*, " & Tbl & ".CodeAgent, " & Tbl & ".MoisRH, " & Tbl & ".AnneeRH " & _
+             "FROM " & Tbl & " " & _
+             "WHERE (((" & Tbl & ".CodeAgent)='" & CodeAgent & "') AND ((" & Tbl & ".MoisRH)=" & moisRH & ") AND ((" & Tbl & ".AnneeRH)=" & anneeRH & "));"
+DoCmd.SetWarnings True
+
+End Function
+
+Public Function invalidation(Tbl As String, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer, avertissement As Integer)
+
+
+If avertissement = 0 Then DoCmd.SetWarnings False
+DoCmd.RunSQL "UPDATE " & Tbl & " SET " & Tbl & ".Valide = False " & _
+             "WHERE (((" & Tbl & ".CodeAgent)='" & CodeAgent & "') AND ((" & Tbl & ".MoisRH)=" & moisRH & ") AND ((" & Tbl & ".AnneeRH)=" & anneeRH & "));"
+DoCmd.SetWarnings True
+
+End Function
+
+
+
+Public Function CumulHS(CodeAgent As String, DateRH As Date) '!!! Obsolete
+Dim moisRH, anneeRH As Integer
+Dim rs As DAO.Recordset
+Dim TotalHS, diff As Double
+
+'total des heures sup du mois (tout compris) jusqu'à la date indiquée
+moisRH = Month(DateRH)
+anneeRH = Year(DateRH)
+TotalHS = 0
+
+Set rs = CurrentDb.OpenRecordset("SELECT tbl_ImportRH.CodeAgent, tbl_ImportRH.DateRH, Month([dateRH]) AS moisRH, Year([dateRH]) AS anneeRH, tbl_ImportRH.HeureSup1, tbl_ImportRH.HeureSup2, tbl_ImportRH.HeureSupDimanche " & _
+                                 "FROM tbl_ImportRH " & _
+                                 "WHERE (((tbl_ImportRH.codeagent) = '" & CodeAgent & "') And ((Month([dateRH])) = " & moisRH & ") And ((Year([dateRH])) = " & anneeRH & ")) " & _
+                                 "ORDER BY tbl_ImportRH.DateRH;")
+
+rs.MoveFirst
+Do Until rs.EOF = True
+  If rs![DateRH] > DateRH Then Exit Do
+  
+  TotalHS = TotalHS + rs![HeureSup1] + rs![HeureSup2] + rs![HeureSupDimanche]
+
+  If rs![DateRH] = DateRH Then Exit Do
+rs.MoveNext
+Loop
+
+CumulHS = TotalHS
+
+End Function
+
+Sub test()
+MsgBox Itineraire("r_FormDep_1", "Localisation", "T32", 2, 12, 2013)
+End Sub
+
+Public Function Itineraire(Requete, Source, ByVal CodeAgent, ByVal JourRH As Integer, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+Dim rst As DAO.Recordset
+Dim critere, strSQL As String
+
+Itineraire = ""
+critere = "[CodeAgent]='" & CodeAgent & "' AND [JourRH]=" & JourRH & " AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+strSQL = "SELECT " & Requete & ".* FROM " & Requete & " WHERE " & critere & ";"
+
+If DCount(Source, Requete, critere) = 0 Then
+ Exit Function
+End If
+
+Set rst = CurrentDb.OpenRecordset(strSQL)
+
+rst.MoveFirst
+Itineraire = Nz(rst(Source), "")
+
+If rst.RecordCount > 1 Then
+ rst.MoveNext
+ Do Until rst.EOF
+    Itineraire = Itineraire & "-" & Nz(rst(Source), "")
+    rst.MoveNext
+ Loop
+End If
+
+Set rst = Nothing
+
+End Function
+
+Public Function HSinf14(H1 As Double, CodeAgent As String, DateRH As Date)
+Dim moisRH, anneeRH As Integer
+Dim rs As DAO.Recordset
+Dim TotalHS As Double
+
+moisRH = Month(DateRH)
+anneeRH = Year(DateRH)
+JourRH = Day(DateRH)
+TotalHS = 0
+
+If JourRH = 1 Then
+  If H1 > 14 Then
+   HSinf14 = 14
+  Else
+   HSinf14 = H1
+  End If
+Else
+
+  'calcul du total des heures sup jusqu'à cette date
+  Set rs = CurrentDb.OpenRecordset("SELECT r_HeuresSup.CodeAgent, r_HeuresSup.JourRH, r_HeuresSup.moisRH, r_HeuresSup.anneeRH, r_HeuresSup.HS, r_HeuresSup.HSNuit, r_HeuresSup.HeureSupDimanche " & _
+                                 "FROM r_HeuresSup " & _
+                                 "WHERE ((r_HeuresSup.codeagent) = '" & CodeAgent & "') And ((r_HeuresSup.moisRH) = " & moisRH & ") And ((r_HeuresSup.anneeRH) = " & anneeRH & ") " & _
+                                 "ORDER BY r_HeuresSup.JourRH;")
+  rs.MoveFirst
+  Do Until rs.EOF = True
+    If rs![JourRH] > JourRH - 1 Then Exit Do
+    TotalHS = TotalHS + Nz(rs![HS], 0) + Nz(rs![HSNuit], 0) + Nz(rs![HeureSupDimanche], 0)
+    If rs![JourRH] = JourRH - 1 Then Exit Do
+  rs.MoveNext
+  Loop
+  Debug.Print JourRH, TotalHS
+  If TotalHS > 14 Then
+   HSinf14 = 0
+  ElseIf TotalHS + H1 > 14 Then
+   HSinf14 = 14 - TotalHS
+  Else
+   HSinf14 = H1
+  End If
+End If
+
+
+End Function
+
+Public Function HSsup14(H1 As Double, CodeAgent As String, DateRH As Date)
+Dim moisRH, anneeRH As Integer
+Dim rs As DAO.Recordset
+Dim TotalHS As Double
+
+moisRH = Month(DateRH)
+anneeRH = Year(DateRH)
+JourRH = Day(DateRH)
+TotalHS = 0
+
+
+If JourRH = 1 Then
+  If H1 > 14 Then
+   HSsup14 = H1 - 14
+  Else
+   HSsup14 = 0
+  End If
+Else
+
+  'calcul du total des heures sup jusqu'à cette date
+  Set rs = CurrentDb.OpenRecordset("SELECT r_HeuresSup.CodeAgent, r_HeuresSup.JourRH, r_HeuresSup.moisRH, r_HeuresSup.anneeRH, r_HeuresSup.HS, r_HeuresSup.HSNuit, r_HeuresSup.HeureSupDimanche " & _
+                                 "FROM r_HeuresSup " & _
+                                 "WHERE ((r_HeuresSup.codeagent) = '" & CodeAgent & "') And ((r_HeuresSup.moisRH) = " & moisRH & ") And ((r_HeuresSup.anneeRH) = " & anneeRH & ") " & _
+                                 "ORDER BY r_HeuresSup.JourRH;")
+  rs.MoveFirst
+  Do Until rs.EOF = True
+    If rs![JourRH] > JourRH - 1 Then Exit Do
+    TotalHS = TotalHS + Nz(rs![HS], 0) + Nz(rs![HSNuit], 0) + Nz(rs![HeureSupDimanche], 0)
+    If rs![JourRH] = JourRH - 1 Then Exit Do
+  rs.MoveNext
+  Loop
+
+  If TotalHS > 14 Then
+   HSsup14 = H1
+  ElseIf TotalHS + H1 > 14 Then
+   HSsup14 = (TotalHS + H1) - 14
+  Else
+   HSsup14 = 0
+  End If
+End If
+
+
+End Function
+
+Public Function Bareme(NomBareme As String, Valeur As Double, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+Dim rs As DAO.Recordset
+Dim PeriodeValidite As Integer
+
+
+PeriodeValidite = PeriodeBareme(NomBareme, moisRH, anneeRH)
+
+Set rs = CurrentDb.OpenRecordset("SELECT * FROM tbl_baremes WHERE [NomBareme]='" & NomBareme & "' AND [PeriodeValidite]=" & PeriodeValidite & ";")
+If rs.RecordCount = 0 Then
+Bareme = 0
+Exit Function
+End If
+rs.MoveFirst
+
+If Nz(rs![BorneInf], "") = "" And Nz(rs![BorneSup], "") = "" Then
+ Bareme = rs![Valeur]
+ Exit Function
+End If
+
+Do Until rs.EOF = True
+ If Valeur >= rs![BorneInf] And Valeur <= rs![BorneSup] Then
+  Bareme = rs![Valeur]
+  Exit Function
+ End If
+rs.MoveNext
+Loop
+
+Bareme = -1
+
+End Function
+
+Public Function AnalyseDonnees(IDSuivi As Double, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer, ByVal avertissement As Integer)
+
+Dim critere, sql As String
+Dim JourRH As Integer
+Dim rsS, rsC As Recordset 'recordset source, recordset cible
+
+'ATTENTION: la requête d'insertion dans tbl_formHS utilise des résultat de la table tbl_FormDep. Celle-ci doit donc impérativement être remplie en premier.
+
+If CodeAgent = "" Or Not anneeRH > 2000 Or Not moisRH <= 12 Or Not moisRH > 0 Then
+ AnalyseDonnees = -1
+ Exit Function
+End If
+
+Call AfficherMsgProgression("Traitement", "Analyse des données de " & CodeAgent & " (" & moisRH & "/" & anneeRH & ")")
+Call MajMsgProgression(1, 5)
+DoEvents
+
+'CREATION FORM DEPLACEMENTS
+'vérification
+If VerifEtat("tbl_FormDep", CodeAgent, moisRH, anneeRH, avertissement) = -1 Then Exit Function '4e arg=0 pour pas d'avertissement avant MAJ/Suppr
+
+ 'ajout des lignes à tbl_formDep
+
+ critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+ sql = "INSERT INTO tbl_FormDep ( AnneeRH, MoisRH, CodeAgent, JourRH, Distance1_perso, Distance2_perso, Distance2_service, Itineraire, HeuresDep, HeuresDepNuit, " & _
+     "Repas, IDSuivi, Valide, CreePar, CreeLe ) " & _
+     "SELECT r_FormDep2.AnneeRH, r_FormDep2.MoisRH, r_FormDep2.CodeAgent, r_FormDep2.JourRH, r_FormDep2.SommeDeDistance1_perso AS Distance1_perso, " & _
+     "r_FormDep2.SommeDeDistance2_perso AS Distance2_perso, r_FormDep2.SommeDeDistance2_service AS Distance2_service, r_FormDep2.Itineraire, " & _
+     "r_FormDep2.SommeDeHeuresDep AS HeuresDep, r_FormDep2.SommeDeHeuresDepNuit AS HeuresDepNuit, r_FormDep2.SommeDeRepas AS Repas, " & _
+     "" & IDSuivi & " AS Expr1, True AS Expr3, '" & Environ("username") & "' AS Expr4, Now() AS Expr5 " & _
+     "FROM r_FormDep2 " & _
+     "WHERE " & critere & ";"
+
+ 'Debug.Print sql
+ If avertissement = 0 Then DoCmd.SetWarnings False
+ DoCmd.RunSQL sql
+ DoCmd.SetWarnings True
+ 
+ Call MajMsgProgression(3, 5)
+'CREATION FORM HEURES SUP
+'vérification
+If VerifEtat("tbl_FormHS", CodeAgent, moisRH, anneeRH, avertissement) = -1 Then Exit Function '4e arg=0 pour pas d'avertissement avant MAJ/Suppr
+
+ 'ajout des lignes à tbl_formHS
+
+ critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+ sql = "INSERT INTO tbl_FormHS ( CodeAgent, JourRH, MoisRH, AnneeRH, HeureSup1, HeuresDep, HeuresDepNuit, " & _
+       "[HeureSup1<=14], [HeureSup1>14], HeureSupNuit, HeureSupDim, HS_VHCanal, HS_Chantier, CreePar, CreeLe, Valide, IDSuivi ) " & _
+       "SELECT r_HeuresSup2.CodeAgent, r_HeuresSup2.JourRH, r_HeuresSup2.MoisRH, r_HeuresSup2.AnneeRH, " & _
+       "r_HeuresSup2.HeureSup1, r_HeuresSup2.HeuresDep, r_HeuresSup2.HeuresDepNuit, " & _
+       "r_HeuresSup2.[H<14], r_HeuresSup2.[H>14], r_HeuresSup2.HSNuit, r_HeuresSup2.HeureSupDimanche, HS_VHCanal, HS_Chantier, " & _
+       "'" & Environ("Username") & "' AS Expr2, Now() AS Expr3, True AS Expr4, " & IDSuivi & " As Expr5 " & _
+       "FROM r_HeuresSup2 " & _
+       "WHERE " & critere & " " & _
+       "ORDER BY [JourRH];"
+       
+ 'Debug.Print sql
+ If avertissement = 0 Then DoCmd.SetWarnings False
+ DoCmd.RunSQL sql
+ DoCmd.SetWarnings True
+
+Call MajMsgProgression(4, 5)
+'AnalyseDonnees = Nz(VerifCompteLignes(CodeAgent, moisRH, anneeRH), -1)
+Call MajMsgProgression(5, 5)
+'résultat: -1 -> erreur inconnue ou mauvais paramètres d'entrée
+          ' 0 -> erreur dans le décompte des lignes
+           '1-> parait être bon
+
+End Function
+
+Public Function TypeAuto(CodeAgent As String, moisRH As Integer, anneeRH As Integer)
+Dim critere As String
+Dim DateRH, validite As Date
+Dim puissance As Double
+'dateRH = CDate("#15/" & moisRH & "/" & anneeRH & "#")
+'validite = LigneValide("tbl_Agents", dateRH, "[CodeAgent]='" & CodeAgent & "'")
+
+critere = "[CodeAgent]='" & CodeAgent & "'"
+
+If DLookup("TypeVehicule", "r_Agents", critere) = 1 Then
+ puissance = Nz(DLookup("PuissanceFiscVP", "r_Agents", critere), 1)
+ TypeAuto = Bareme("Puissance Fiscale", puissance, moisRH, anneeRH)
+Else
+ TypeAuto = ""
+End If
+End Function
+
+Public Function DistanceAnnee(CodeAgent As String, moisRH As Integer, anneeRH As Integer)
+'cette fonction renvoie le nombre de kilomètres parcourus par l'agent depuis le début de l'année
+'jusqu'au mois indiqué NON-COMPRIS
+'Cette fonction est utilisée dans le calcul des frais kilométriques
+'Des kilomètres additionnels peuvent être ajoutés manuellement lors de la création d'un nouvel agent (cf. tbl_KmSuppl)
+
+Dim rs As DAO.Recordset
+Dim Distance As Double
+Dim KmSuppl As Double
+
+If CodeAgent = "" Or Not anneeRH > 2000 Or Not moisRH <= 12 Or Not moisRH > 0 Then
+ DistanceAnnee = 0
+ MsgBox "Erreur Paramètres dans l'appel de la fonction DistanceAnnee"
+ Exit Function
+End If
+
+DistanceAnnee = 0
+
+'recherche d'éventuels km supplémentaires
+KmSuppl = Nz(DSum("KmSuppl", "tbl_KmSuppl", "[CodeAgent]='" & CodeAgent & "' AND [AnneeRH]=" & anneeRH), 0)
+
+DistanceAnnee = KmSuppl
+
+If moisRH = 1 Then 'cas du mois de janvier
+ Exit Function
+End If
+
+Set rs = CurrentDb.OpenRecordset("SELECT tbl_FormDep.CodeAgent, tbl_FormDep.JourRH, tbl_FormDep.MoisRH, tbl_FormDep.AnneeRH, tbl_FormDep.Distance2_perso, tbl_FormDep.Distance1_perso, [Distance2_perso]+[Distance1_perso] AS DistancePerso " & _
+                                 "FROM tbl_FormDep WHERE (((tbl_FormDep.CodeAgent)='" & CodeAgent & "') AND ((tbl_FormDep.MoisRH)<" & moisRH & ") AND ((tbl_FormDep.AnneeRH)=" & anneeRH & "));")
+Distance = 0
+If rs.RecordCount > 0 Then
+ rs.MoveFirst
+ Do Until rs.EOF = True
+  Distance = Distance + rs![DistancePerso]
+  rs.MoveNext
+ Loop
+End If
+DistanceAnnee = DistanceAnnee + Distance
+
+End Function
+
+Public Function NvellePeriode(ByVal table As String, ByVal Champ1_valeur As String, ByVal DateInf As Date)
+'cette fonction permet la création d'une nouvelle periode de validité dans la table tbl_Periodebareme ou tbl_PeriodeAgent
+'le champ1 correspond selon la table au code de l'agent ou au nom du bareme
+'la fonction attribue une date de fin à l'ancienne periode, créé la nouvelle période, et lui attribue un nouveau code et une date de début
+
+Dim rs As DAO.Recordset
+Dim champ1_nom, sql, msg As String
+Dim conflit, avertissement, CodePeriode, AnciennePeriode As Integer
+Dim dateconflit As Date
+
+Set rs = CurrentDb.OpenRecordset(table)
+champ1_nom = rs.Fields(0).Name
+
+avertissement = parametre("avertSQL")
+conflit = CtrlValidite(table, Champ1_valeur, DateInf)
+
+CodePeriode = Nz(DMax("[CodePeriode]", table, "[" & champ1_nom & "]='" & Champ1_valeur & "'"), 0) + 1
+'la fonction CtrlValidite renvoie le code de la période avec laquelle la nouvelle date entre en conflit
+'si ce code est positif, la nouvelle date est comprise dans la période en question
+'s'il est négatif, elle y est antérieure et la date de fin sera automatiquement remplie
+
+
+If conflit <> 0 Then
+ Select Case conflit
+  Case Is < 0
+   dateconflit = DLookup("[DateInf]", table, "[" & champ1_nom & "]='" & Champ1_valeur & "' AND [CodePeriode]=" & -1 * conflit)
+   If IsNull(dateconflit) Then
+     msg = "Erreur: conflit avec la periode " & -1 * conflit & ". Veuillez vérifier la date de début de cette période ou contacter un administrateur."
+     NvellePeriode = 0
+     Exit Function
+   Else
+     msg = "ATTENTION: La date choisie est antérieure à une période existante (période " & -1 * conflit & ") dont la date de début est " & _
+           dateconflit & "." & vbNewLine & "Si vous continuez, la date de fin de la période en création sera automatiquement enregistrée comme étant " & dateconflit - 1 & "."
+     If MsgBox(msg, vbYesNo) = vbNo Then
+      NvellePeriode = 0
+      Exit Function
+     End If
+   End If
+  Case Is > 0
+   msg = "ATTENTION: La date choisie est comprise dans une période existante (période " & conflit & "). " & vbNewLine & "Veuillez choisir une autre date ou contacter un administrateur."
+   MsgBox msg
+   NvellePeriode = 0
+   Exit Function
+ End Select
+End If
+
+ msg = "Une nouvelle période va être créée qui prendra effet à compter du " & DateInf
+ If MsgBox(msg, vbYesNo) = vbNo Then
+  NvellePeriode = 0
+  Exit Function
+ End If
+
+If avertissement = 0 Then DoCmd.SetWarnings False
+
+Select Case conflit
+
+ Case 0
+  AnciennePeriode = Nz(DLookup("[CodePeriode]", table, "[" & champ1_nom & "]='" & Champ1_valeur & "' AND [DateSup] is null"), 0)
+  'fermeture de l'ancienne periode
+  If AnciennePeriode <> 0 Then
+   sql = "UPDATE " & table & " SET " & table & ".DateSup = Format(#" & CDate(DateInf) - 1 & "#,'mm/dd/yyyy') " & _
+         "WHERE (((" & table & "." & champ1_nom & ")='" & Champ1_valeur & "') AND ((" & table & ".CodePeriode)=" & AnciennePeriode & "));"
+   DoCmd.RunSQL sql
+  End If
+  'creation de la nouvelle periode
+
+  rs.AddNew
+  rs(champ1_nom) = Champ1_valeur
+  rs![DateInf] = CDate(DateInf)
+  rs![CodePeriode] = CodePeriode
+  rs.Update
+
+ Case Is < 0
+
+  'creation de la nouvelle periode avec pour date de fin la veille de la période qui suit
+
+  rs.AddNew
+  rs(champ1_nom) = Champ1_valeur
+  rs![DateInf] = DateInf
+  rs![DateSup] = dateconflit - 1
+  rs![CodePeriode] = CodePeriode
+  rs.Update
+ 
+ 
+End Select
+DoCmd.SetWarnings True
+
+NvellePeriode = CodePeriode
+
+End Function
+
+
+Public Function EtatSuivi(CodeAgent As String, moisRH As Integer, anneeRH As Integer)
+'renvoie l'état des données depuis tbl_SuiviRH
+Dim critere As String
+If CodeAgent <> "" And anneeRH > 2000 And moisRH <= 12 And moisRH > 0 Then
+ critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+ If Nz(DLookup("[Edite]", "tbl_SuiviRH", critere), False) = False Then
+  EtatSuivi = Nz(DLookup("[Etat]", "tbl_SuiviRH", critere), "Pas de données")
+ Else
+  EtatSuivi = "Edité"
+ End If
+Else
+ EtatSuivi = "erreur"
+End If
+End Function

test/source/modules/Utilitaires.bas

@@ -0,0 +1,350 @@
+Option Compare Database
+Private Const BIF_RETURNONLYFSDIRS = 1
+Private Const BIF_DONTGOBELOWDOMAIN = 2
+Private Const BIF_NEWDIALOGSTYLE As Long = &H40
+
+Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
+Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
+    ByVal lpBuffer As String) As Long
+Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
+    ByVal lpString2 As String) As Long
+
+Private Type BrowseInfo
+    hwndOwner As Long
+    pIDLRoot As Long
+    pszDisplayName As Long
+    lpszTitle As Long
+     ulFlags As Long
+    lpfnCallback As Long
+    lParam As Long
+    iImage As Long
+End Type
+
+Function Environ(VarName)
+    Dim wss, env
+    Set wss = CreateObject("WScript.Shell")
+    Set env = wss.environment("process")
+    Environ = env(VarName)
+    If Environ = "" Then
+        Set env = wss.environment("system")
+        Environ = env(VarName)
+    End If
+End Function
+
+Public Sub ImprEtats(ByVal stEtat As String, ByVal itCopies As Integer, ByVal critere As String)
+'imprime un état en plusieurs exemplaires
+ ' stEtat   : nom de l'état
+ ' itCopies : nombre de copies
+DoCmd.OpenReport stEtat, acViewPreview, , critere
+DoCmd.PrintOut acPages, , , , itCopies
+DoCmd.Close acReport, stEtat
+End Sub
+
+Public Sub ExportBordereau(ByVal NomBord As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+Dim OuvAutoPdf As Boolean
+Dim NomMois, repPDF As String
+
+If MsgBox("Voulez-vous ouvrir le PDF une fois créé?", vbYesNo) = vbYes Then
+ OuvAutoPdf = True
+Else
+ OuvAutoPdf = False
+End If
+
+repPDF = chemin(moisRH, anneeRH)
+NomMois = Left(UCase(MonthName(moisRH)), 4)
+
+If repPDF = "" Then
+ Call MsgBox("Vous devez définir un répertoire de stockage pour utiliser cette fonction.", , NomEtat)
+ Exit Sub
+End If
+
+If dir(repPDF, 16) = "" Then MkDir (repPDF)
+
+critere = "[MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+DoCmd.OpenReport NomBord, acViewPreview, , critere
+DoCmd.OutputTo acOutputReport, , "PDF", repPDF & NomBord & "_" & NomMois & anneeRH & ".pdf", OuvAutoPdf
+DoCmd.Close acReport, NomBord
+
+End Sub
+
+Public Sub ExportEtatPDF(ByVal NomEtat As String, ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer)
+Dim OuvAutoPdf As Boolean
+Dim NomMois, repPDF, nomFichier, NomAgent, critere, str As String
+
+OuvAutoPdf = False
+
+NomAgent = Nz(Split(DLookup("Nom", "r_Agents", "[CodeAgent]='" & CodeAgent & "'"), " ")(0), "") & "." & _
+           Left(Nz(Split(DLookup("Nom", "r_Agents", "[CodeAgent]='" & CodeAgent & "'"), " ")(1), ""), 1)
+
+If NomAgent = "" Then
+  'erreur nom
+  NomAgent = Nz(InputBox("L'application n'a pas trouvé le nom de famille de l'agent. Celui ci doit se trouver dans la table tbl_Equipe, au format 'NOM Prenom'. Vous pouvez le renseigner manuellement:"), "")
+  If NomAgent = "" Then Exit Sub
+End If
+
+repPDF = chemin(moisRH, anneeRH)
+'NomMois = Left(UCase(MonthName(moisRH)), 4)
+'NomFichier=NomAgent & "_" & NomMois & anneeRH & "_" & NomEtat & ".pdf"
+
+
+If Len(CStr(moisRH)) = 1 Then
+  NomMois = anneeRH & "0" & moisRH
+Else
+  NomMois = anneeRH & moisRH
+End If
+
+nomFichier = NomAgent & "_" & NomMois & "_" & NomEtat & ".pdf"
+
+If repPDF = "" Then
+ Call MsgBox("Vous devez définir un répertoire de stockage pour utiliser cette fonction.", , NomEtat)
+ Exit Sub
+End If
+
+If dir(repPDF, 16) = "" Then MkDir (repPDF)
+
+critere = "[CodeAgent]='" & CodeAgent & "' AND [MoisRH]=" & moisRH & " AND [AnneeRH]=" & anneeRH
+
+nomFichier = repPDF & NomAgent & "_" & NomMois & "_" & Replace(NomEtat, "Et_", "") & ".pdf"
+
+DoCmd.OpenReport NomEtat, acViewPreview, , critere
+DoCmd.OutputTo acOutputReport, , "PDF", nomFichier, OuvAutoPdf
+DoCmd.Close acReport, NomEtat
+
+End Sub
+
+
+
+
+Public Function SelectFolder(titre As String, Handle As Long) As String
+
+Dim lpIDList As Long
+Dim strBuffer As String
+Dim strTitre As String
+Dim tBrowseInfo As BrowseInfo
+
+strTitre = titre
+With tBrowseInfo
+    .hwndOwner = Handle
+    .lpszTitle = lstrcat(strTitre, "")
+    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE
+End With
+
+lpIDList = SHBrowseForFolder(tBrowseInfo)
+
+If (lpIDList) Then
+    strBuffer = String(260, vbNullChar)
+    SHGetPathFromIDList lpIDList, strBuffer
+    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
+End If
+
+End Function
+
+Public Function NomImpr(Optional PremCo As Boolean)
+'ouvre le formulaire frm_ChoixImpr et renvoie le nom de l'imprimante choisie
+
+'ouverture du formulaire
+DoCmd.OpenForm "frm_ChoixImpr"
+
+If PremCo = True Then MsgBox "VEUILLEZ TOUT D'ABORD CHOISIR L'IMPRIMANTE QUE DEVRA UTILISER VOTRE APPLICATION" & vbNewLine & "(Vous pourrez ensuite en changer à partir du menu 'parametres', accessible depuis l'écran d'accueil)"
+
+'la fonction reste en attente jusqu'à ce qu'une imprimante ait été choisie
+Do Until Nz(forms![frm_ChoixImpr].impr, "") <> ""
+ DoEvents
+Loop
+
+'récupération du nom de l'imprimante
+If Not forms![frm_ChoixImpr].impr = "annuler" Then
+ NomImpr = Nz(forms![frm_ChoixImpr].impr, "")
+Else
+ NomImpr = ""
+End If
+'fermeture du formulaire
+DoCmd.Close acForm, "frm_ChoixImpr"
+
+End Function
+
+Public Function Attendre(tps As Double)
+'tps en ms
+Dim t0, t As Single
+
+t0 = Timer
+
+Do Until 1000 * (t - t0) >= tps
+ t = Timer
+ DoEvents
+Loop
+
+End Function
+
+Sub testchrono()
+MsgBox "1"
+Call Attendre(5000) '5s
+MsgBox "2"
+End Sub
+
+Public Function OuvrirRepertoire(chemin As String)
+ 
+    'validité du chemin
+    If (IsNull(chemin)) Then
+        MsgBox ("Chemin d'accès non valide")
+        Exit Function
+    End If
+    
+    'existence du répertoire
+    If (dir(chemin, vbDirectory) <> "") Then
+        'Appel de l'explorateur Windows
+        Shell "explorer " & chemin, vbNormalFocus
+    Else
+        MsgBox ("Ce répertoire n'existe pas")
+    End If
+ 
+End Function
+
+Public Function ChercherNomFichier()
+Dim initialFileName As Variant
+
+' Displays the Office File Open dialog to choose a file name
+' for the current employee record.
+Dim fileName As String
+Dim result As Integer
+
+
+With Application.FileDialog(3) ' 3 is a constant: msoFileDialogFilePicker
+.Title = "Selection d'un fichier à importer"
+.Filters.Add "All Files", "*.*"
+.Filters.Add "XML", "*.xml"
+.FilterIndex = 2
+.AllowMultiSelect = False
+
+
+initialFileName = DLookup("Valeur", "tbl_parametre", "Parametre = 'RepXML'")
+If dir(initialFileName) = "" Then initialFileName = DLookup("Valeur", "tbl_parametre", "Parametre = 'RepXML_defaut'")
+
+If IsNull(initialFileName) Then
+    initialFileName = fCurrentDBDir
+End If
+.initialFileName = initialFileName
+result = .Show
+If (result <> 0) Then 'result = 0 if nothing was selected
+fileName = Trim(.SelectedItems.Item(1))
+'filename contains the path you want.
+ChercherNomFichier = fileName
+
+End If
+End With
+
+End Function
+
+
+Public Sub ImportXMLPDA(ByVal strfilename As String)
+
+'déclaration file system object
+Dim FSO
+'instanciation
+Set FSO = CreateObject("Scripting.FileSystemObject")
+
+'importation des données xml
+Application.ImportXML DataSource:=strfilename, ImportOptions:=acAppendData
+    
+End Sub
+
+Public Function ExtraitNomFichier(strNomFichierCplt As String) As String
+Dim i, j As Long
+j = InStr(1, strNomFichierCplt, "\")
+Do
+i = j
+j = InStr(i + 1, strNomFichierCplt, "\")
+Loop Until j = 0
+ExtraitNomFichier = Mid(strNomFichierCplt, i + 1, Len(strNomFichierCplt) - i)
+End Function
+Public Function ExtraitNomRep(strNomFichierCplt As String) As String
+Dim i, j As Long
+j = InStr(1, strNomFichierCplt, "\")
+Do
+i = j
+j = InStr(i + 1, strNomFichierCplt, "\")
+Loop Until j = 0
+ExtraitNomRep = Mid(strNomFichierCplt, 1, i)
+End Function
+
+Function ReformateDate(InputDate As String) As Date 'change le format date importé en format intelligible ACCESS
+
+Dim DateCourte As String
+Dim y As String
+Dim m As String
+Dim d As String
+Dim DateOrdre As String
+
+DateCourte = Left(InputDate, 10)
+y = Left(DateCourte, 4)
+m = Mid(DateCourte, 6, 2)
+d = Right(DateCourte, 2)
+DateOrdre = d & "/" & m & "/" & y
+ReformateDate = CDate(DateOrdre)
+
+End Function
+
+Public Function NomAgentAbrege(Nom As String)
+
+If Not Len(Nom) > 0 Or Not UBound(Split(Nom, " ")) > 0 Then
+ NomAgentAbrege = Nom
+ Exit Function
+End If
+
+NomAgentAbrege = Left(Split(Nom, " ")(1), 1) & "." & Split(Nom, " ")(0)
+
+End Function
+
+Public Function parametre(ByVal param As String, Optional ByVal valeur2 As String)
+'renvoie la valeur d'un paramètre demandé depuis tbl_parametre
+Dim critere As String
+
+If Not IsNull(valeur2) And valeur2 <> "" Then
+ critere = "[parametre]='" & param & "' AND [valeur2]='" & valeur2 & "'"
+Else
+ critere = "[parametre]='" & param & "'"
+End If
+
+parametre = Nz(DLookup("valeur", "tbl_parametre", critere), Null)
+
+
+End Function
+
+Public Function chemin(ByVal moisRH As Integer, ByVal anneeRH As Integer)
+'renvoie la valeur du répertoire PDF de la table tbl_ParamUtil
+Dim critere, str As String
+
+critere = "[parametre]='repPDF' AND [User]='" & CurrentUser & "'"
+
+If Not moisRH > 0 Or Not moisRH <= 12 Or Not anneeRH > 2000 Then
+chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "")
+Exit Function
+End If
+
+'chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "") & "\" & Left(UCase(MonthName(moisRH)), 4) & anneeRH & "\"
+
+chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "")
+If Right(chemin, 1) <> "\" Then chemin = chemin & "\"
+
+str = CStr(anneeRH) & "-"
+If Len(CStr(moisRH)) = 1 Then str = str & "0"
+str = str & moisRH
+
+chemin = Nz(DLookup("valeur", "tbl_ParamUtil", critere), "") & str & "\"
+
+End Function
+
+Public Sub MAJParametre(ByVal param As String, ByVal Valeur As Variant, Optional ByVal valeur2 As String)
+'met à jour une valeur de la table parametre
+Dim critere As String
+
+If Not Nz(valeur2, "") = "" Then
+ critere = "[parametre]='" & param & "' AND [valeur2]='" & valeur2 & "'"
+Else
+ critere = "[parametre]='" & param & "'"
+End If
+DoCmd.SetWarnings False
+DoCmd.RunSQL "UPDATE tbl_parametre SET tbl_parametre.valeur = '" & Valeur & "' WHERE " & critere & ";"
+DoCmd.SetWarnings True
+End Sub

test/source/modules/Verrouillages.bas

@@ -0,0 +1,395 @@
+Option Compare Database
+
+'on trouve ici les fonctions qui controlent le verrouillage, la visibilité... des différents formulaires
+
+Public Function acces(ByVal login As String) As Integer
+
+'util = parametre("acces", CurrentUser)
+Util = Nz(DLookup("[acces]", "ztblUtilisateurs", "[login]='" & login & "'"), "")
+If Util = "admin" Then
+ acces = 2
+ElseIf Util = "rw" Then
+ acces = 1
+Else
+ acces = 0
+End If
+
+End Function
+
+Public Sub VerrouMenu(niv As Integer)
+Dim Util As String
+
+'RW/administrateur?
+
+With forms![frm_menu]
+ .txt_donnee.Visible = False
+ .CreerForm.Enabled = False
+ .FDep_Ouvrir.Enabled = False
+ .FDep_Ouvrir.QuickStyle = 22
+ .FHS_Ouvrir.Enabled = False
+ .FHS_Ouvrir.QuickStyle = 22
+ .EFD_Ouvrir.Enabled = False
+ .EFD_Ouvrir.QuickStyle = 22
+ .exportPeriple.Enabled = False
+ .exportPeriple.QuickStyle = 22
+ .CmdImpr.Enabled = False
+ .EnregPDF.Enabled = False
+ .BordEFD.Enabled = False
+ .BordHS.Enabled = False
+ .BordHSImpr.Enabled = False
+ .BordEFDImpr.Enabled = False
+ .BordHSpdf.Enabled = False
+ .BordEFDpdf.Enabled = False
+ .ValidForm.Enabled = False
+ .InvalidForm.Enabled = False
+ .DonneesAgentValide.Enabled = False
+ .BaremeValide.Enabled = False
+ .etiq_nodata.Visible = False
+ .Edition.Visible = False
+ If acces(CurrentUser) < 2 Then .InvalidForm.Visible = False
+ If acces(CurrentUser) < 2 Then .Administration.Visible = False
+
+  Select Case niv
+
+   Case 0
+     'verrouillage total (par exemple pendant un traitement de données)
+ 
+   Case 5
+     'mois et année selectionnés, mais pas l'agent
+     .BaremeValide.Enabled = True
+ 
+   Case 6
+     'pas d'agent selectionné, des données importées pour ce mois
+     .BaremeValide.Enabled = True
+     .BordEFD.Enabled = True
+     .BordHS.Enabled = True
+     .BordHSImpr.Enabled = True
+     .BordEFDImpr.Enabled = True
+     .BordHSpdf.Enabled = True
+     .BordEFDpdf.Enabled = True
+   
+   Case 1
+     'pas de données pour ce mois
+     .etiq_nodata.Visible = True
+     .DonneesAgentValide.Enabled = True
+     .BaremeValide.Enabled = True
+ 
+   Case 2
+     'données importées mais pas analysées
+
+     .txt_donnee.Visible = True
+     If acces(CurrentUser) >= 1 Then forms![frm_menu].CreerForm.Enabled = True
+     .BordEFD.Enabled = True
+     .BordHS.Enabled = True
+     .DonneesAgentValide.Enabled = True
+     .BaremeValide.Enabled = True
+     .BordHSImpr.Enabled = True
+     .BordEFDImpr.Enabled = True
+     .BordHSpdf.Enabled = True
+     .BordEFDpdf.Enabled = True
+     .exportPeriple.Enabled = True
+     .exportPeriple.QuickStyle = 21
+ 
+   Case 3
+     'données importées, analysées, pas validées
+ 
+     .txt_donnee.Visible = True
+     If acces(CurrentUser) >= 1 Then forms![frm_menu].CreerForm.Enabled = True
+       .FDep_Ouvrir.Enabled = True
+       .FDep_Ouvrir.QuickStyle = 21
+       .FHS_Ouvrir.Enabled = True
+       .FHS_Ouvrir.QuickStyle = 21
+       .EFD_Ouvrir.Enabled = True
+       .EFD_Ouvrir.QuickStyle = 21
+       .BordEFD.Enabled = True
+       .BordHS.Enabled = True
+     If acces(CurrentUser) >= 1 Then forms![frm_menu].ValidForm.Enabled = True
+       .DonneesAgentValide.Enabled = True
+       .BaremeValide.Enabled = True
+       .BordHSImpr.Enabled = True
+       .BordEFDImpr.Enabled = True
+       .BordHSpdf.Enabled = True
+       .BordEFDpdf.Enabled = True
+     .exportPeriple.Enabled = True
+     .exportPeriple.QuickStyle = 21
+     
+   Case 4
+     'données importées, analysées, et validées
+ 
+     If acces(CurrentUser) = 2 Then .InvalidForm.Visible = True
+     If acces(CurrentUser) = 2 Then .InvalidForm.Enabled = True
+     .txt_donnee.Visible = True
+     .FDep_Ouvrir.Enabled = True
+     .FDep_Ouvrir.QuickStyle = 21
+     .FHS_Ouvrir.Enabled = True
+     .FHS_Ouvrir.QuickStyle = 21
+     .EFD_Ouvrir.Enabled = True
+     .EFD_Ouvrir.QuickStyle = 21
+     If acces(CurrentUser) >= 1 Then .CmdImpr.Enabled = True
+     If acces(CurrentUser) >= 1 Then .EnregPDF.Enabled = True
+     .BordEFD.Enabled = True
+     .BordHS.Enabled = True
+     .DonneesAgentValide.Enabled = True
+     .BaremeValide.Enabled = True
+     .BordHSImpr.Enabled = True
+     .BordEFDImpr.Enabled = True
+     .BordHSpdf.Enabled = True
+     .BordEFDpdf.Enabled = True
+     .exportPeriple.Enabled = True
+     .exportPeriple.QuickStyle = 21
+  End Select
+
+End With
+
+End Sub
+
+Public Sub VerrouMAJAgent(niv As Integer)
+'gestion des verrouillages du formulaire frm_MAJAgent
+
+forms![frm_MAJAgent].DateInf.Locked = True
+forms![frm_MAJAgent].NvelleDate.Locked = True
+forms![frm_MAJAgent].CopieAnc.Locked = True
+forms![frm_MAJAgent].CodeAgent.Locked = True
+forms![frm_MAJAgent].Nom.Locked = True
+forms![frm_MAJAgent].Grade.Locked = True
+forms![frm_MAJAgent].Catégorie.Locked = True
+forms![frm_MAJAgent].RémunérationBase.Locked = True
+forms![frm_MAJAgent].Groupe.Locked = True
+forms![frm_MAJAgent].Matricule.Locked = True
+forms![frm_MAJAgent].TypeVehicule.Locked = True
+forms![frm_MAJAgent].DateAutorisationVP.Locked = True
+forms![frm_MAJAgent].PuissanceFiscVP.Locked = True
+forms![frm_MAJAgent].NbKmAutorisesVP.Locked = True
+forms![frm_MAJAgent].ResidenceAdmin.Locked = True
+forms![frm_MAJAgent].ResidenceFamiliale.Locked = True
+forms![frm_MAJAgent].Telephone.Locked = True
+forms![frm_MAJAgent].TypeVirement.Locked = True
+
+forms![frm_MAJAgent].txt_ancdate.Visible = True
+forms![frm_MAJAgent].txt_nvdate.Visible = True
+forms![frm_MAJAgent].txt_copie.Visible = True
+
+forms![frm_MAJAgent].txt_edition.Visible = False
+
+forms![frm_MAJAgent].CmdOK.Enabled = False
+
+
+Select Case niv
+
+Case 0 'mise à jour du formulaire: déverouillage total
+forms![frm_MAJAgent].DateInf.Locked = False
+forms![frm_MAJAgent].NvelleDate.Locked = False
+forms![frm_MAJAgent].CopieAnc.Locked = False
+forms![frm_MAJAgent].CodeAgent.Locked = False
+forms![frm_MAJAgent].Nom.Locked = False
+forms![frm_MAJAgent].Grade.Locked = False
+forms![frm_MAJAgent].Catégorie.Locked = False
+forms![frm_MAJAgent].RémunérationBase.Locked = False
+forms![frm_MAJAgent].Groupe.Locked = False
+forms![frm_MAJAgent].Matricule.Locked = False
+forms![frm_MAJAgent].TypeVehicule.Locked = False
+forms![frm_MAJAgent].DateAutorisationVP.Locked = False
+forms![frm_MAJAgent].PuissanceFiscVP.Locked = False
+forms![frm_MAJAgent].NbKmAutorisesVP.Locked = False
+forms![frm_MAJAgent].ResidenceAdmin.Locked = False
+forms![frm_MAJAgent].ResidenceFamiliale.Locked = False
+forms![frm_MAJAgent].Telephone.Locked = False
+forms![frm_MAJAgent].TypeVirement.Locked = False
+
+
+Case 1 'ouverture du form, tout est verrouillé sauf la date de début de la nouvelle période et l'option copie des anciennes données
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJAgent].NvelleDate.Locked = False
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJAgent].CopieAnc.Locked = False
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJAgent].CmdOK.Enabled = True
+
+Case 2 'renseignement des nouvelles données
+
+ forms![frm_MAJAgent].txt_ancdate.Visible = False
+ forms![frm_MAJAgent].txt_nvdate.Visible = False
+ forms![frm_MAJAgent].txt_copie.Visible = False
+ forms![frm_MAJAgent].NvelleDate.Visible = False
+ forms![frm_MAJAgent].CopieAnc.Visible = False
+ forms![frm_MAJAgent].CmdOK.Visible = False
+
+ forms![frm_MAJAgent].txt_edition.Visible = True
+
+ forms![frm_MAJAgent].Grade.Locked = False
+ forms![frm_MAJAgent].Catégorie.Locked = False
+ forms![frm_MAJAgent].RémunérationBase.Locked = False
+ forms![frm_MAJAgent].Groupe.Locked = False
+ forms![frm_MAJAgent].Matricule.Locked = False
+ forms![frm_MAJAgent].TypeVehicule.Locked = False
+ forms![frm_MAJAgent].DateAutorisationVP.Locked = False
+ forms![frm_MAJAgent].PuissanceFiscVP.Locked = False
+ forms![frm_MAJAgent].NbKmAutorisesVP.Locked = False
+ forms![frm_MAJAgent].ResidenceAdmin.Locked = False
+ forms![frm_MAJAgent].ResidenceFamiliale.Locked = False
+ forms![frm_MAJAgent].Telephone.Locked = False
+ forms![frm_MAJAgent].TypeVirement.Locked = False
+
+End Select
+
+
+End Sub
+
+
+
+Public Sub VerrouMAJbareme(niv As Integer)
+'gestion des verrouillages du formulaire frm_MAJBareme
+
+
+forms![frm_MAJBareme].DateInf.Locked = True
+forms![frm_MAJBareme].NvelleDate.Locked = True
+forms![frm_MAJBareme].CopieAnc.Locked = True
+forms![frm_MAJBareme].BorneInf.Locked = True
+forms![frm_MAJBareme].BorneSup.Locked = True
+forms![frm_MAJBareme].UniteBornes.Locked = True
+forms![frm_MAJBareme].Valeur.Locked = True
+forms![frm_MAJBareme].UniteValeur.Locked = True
+
+forms![frm_MAJBareme].txt_ancdate.Visible = True
+forms![frm_MAJBareme].txt_nvdate.Visible = True
+forms![frm_MAJBareme].txt_copie.Visible = True
+
+forms![frm_MAJBareme].txt_edition.Visible = False
+
+forms![frm_MAJBareme].CmdOK.Enabled = False
+forms![frm_MAJBareme].InserLigne.Visible = False
+forms![frm_MAJBareme].SupprLigne.Visible = False
+
+Select Case niv
+
+Case 0 'mise à jour du formulaire: déverouillage total
+forms![frm_MAJBareme].DateInf.Locked = False
+forms![frm_MAJBareme].NvelleDate.Locked = False
+forms![frm_MAJBareme].CopieAnc.Locked = False
+forms![frm_MAJBareme].BorneInf.Locked = False
+forms![frm_MAJBareme].BorneSup.Locked = False
+forms![frm_MAJBareme].UniteBornes.Locked = False
+forms![frm_MAJBareme].Valeur.Locked = False
+forms![frm_MAJBareme].UniteValeur.Locked = False
+
+
+Case 1 'ouverture du form, tout est verrouillé sauf la date de début de la nouvelle période et l'option copie des anciennes données
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJBareme].NvelleDate.Locked = False
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJBareme].CopieAnc.Locked = False
+ If acces(CurrentUser) >= 1 Then forms![frm_MAJBareme].CmdOK.Enabled = True
+
+Case 2 'renseignement des nouvelles données
+
+ forms![frm_MAJBareme].BorneInf.Locked = False
+ forms![frm_MAJBareme].BorneSup.Locked = False
+ forms![frm_MAJBareme].Valeur.Locked = False
+ forms![frm_MAJBareme].UniteBornes.Locked = False
+ forms![frm_MAJBareme].UniteValeur.Locked = False
+
+ forms![frm_MAJBareme].txt_ancdate.Visible = False
+ forms![frm_MAJBareme].txt_nvdate.Visible = False
+ forms![frm_MAJBareme].txt_copie.Visible = False
+ forms![frm_MAJBareme].NvelleDate.Visible = False
+ forms![frm_MAJBareme].CopieAnc.Visible = False
+ forms![frm_MAJBareme].CmdOK.Visible = False
+
+ forms![frm_MAJBareme].InserLigne.Visible = True
+ forms![frm_MAJBareme].SupprLigne.Visible = True
+
+ forms![frm_MAJBareme].txt_edition.Visible = True
+
+End Select
+
+
+End Sub
+
+Public Sub VerrouSfrmDetailBareme(frm As Object, niv As Integer)
+
+
+With frm
+
+ If acces(CurrentUser) = 0 Then
+  .MAJBareme.Visible = False
+ End If
+
+.[sfrm_detailbareme].Form.Valeur.SetFocus 'un contrôle doit être actif, et rester visible
+
+.[sfrm_detailbareme].Form.NomBareme.Visible = False
+.[sfrm_detailbareme].Form.BorneInf.Visible = False
+.[sfrm_detailbareme].Form.BorneSup.Visible = False
+.[sfrm_detailbareme].Form.De.Visible = False
+.[sfrm_detailbareme].Form.A.Visible = False
+.[sfrm_detailbareme].Form.UniteBornes.Visible = False
+.[sfrm_detailbareme].Form.UniteValeur.Visible = False
+.[sfrm_detailbareme].Form.par.Visible = False
+Select Case niv
+
+Case 0 'pas de données
+
+
+Case 1 'le barême est un simple coefficient 'ex: tarif des repas
+.[sfrm_detailbareme].Form.par.Visible = True
+.[sfrm_detailbareme].Form.UniteBornes.Visible = True
+.[sfrm_detailbareme].Form.NomBareme.Visible = True
+.[sfrm_detailbareme].Form.UniteValeur.Visible = True
+
+Case 2 'barême (ex: frais kilométriques)
+.[sfrm_detailbareme].Form.NomBareme.Visible = True
+.[sfrm_detailbareme].Form.BorneInf.Visible = True
+.[sfrm_detailbareme].Form.BorneSup.Visible = True
+.[sfrm_detailbareme].Form.De.Visible = True
+.[sfrm_detailbareme].Form.A.Visible = True
+.[sfrm_detailbareme].Form.UniteBornes.Visible = True
+.[sfrm_detailbareme].Form.UniteValeur.Visible = True
+
+End Select
+End With
+End Sub
+
+
+Public Sub VerrouNouvelAgent()
+'gestion des verrouillages du formulaire frm_NouvelAgent
+
+End Sub
+
+Public Sub VerrouDonneesImport(niv As Integer)
+
+Select Case niv
+
+Case 0
+' pas de verouillage
+  forms![frm_donneesRH].strEquipesLibelle.Enabled = True
+  forms![frm_donneesRH].DateRH.Enabled = True
+  forms![frm_donneesRH].CodeChantier.Enabled = True
+  forms![frm_donneesRH].CodeLocalisation.Enabled = True
+  'Forms![frm_donneesRH].Localisation.Enabled = True
+  forms![frm_donneesRH].strCategorieInterventionId.Enabled = True
+  forms![frm_donneesRH].HeureSup1.Enabled = True
+  forms![frm_donneesRH].HeureSup2.Enabled = True
+  forms![frm_donneesRH].HeureSupDimanche.Enabled = True
+  forms![frm_donneesRH].Repas.Enabled = True
+  forms![frm_donneesRH].DistanceTranche1.Enabled = True
+  forms![frm_donneesRH].VehiculePersoTranche1.Enabled = True
+  forms![frm_donneesRH].DistanceTranche2.Enabled = True
+  forms![frm_donneesRH].VehiculePersoTranche2.Enabled = True
+  forms![frm_donneesRH].FichierXml.Enabled = True
+  
+Case 1
+' verrouillage
+  forms![frm_donneesRH].strEquipesLibelle.Enabled = False
+  forms![frm_donneesRH].DateRH.Enabled = False
+  forms![frm_donneesRH].CodeChantier.Enabled = False
+  forms![frm_donneesRH].CodeLocalisation.Enabled = False
+  'Forms![frm_donneesRH].Localisation.Enabled = False
+  forms![frm_donneesRH].strCategorieInterventionId.Enabled = False
+  forms![frm_donneesRH].HeureSup1.Enabled = False
+  forms![frm_donneesRH].HeureSup2.Enabled = False
+  forms![frm_donneesRH].HeureSupDimanche.Enabled = False
+  forms![frm_donneesRH].Repas.Enabled = False
+  forms![frm_donneesRH].DistanceTranche1.Enabled = False
+  forms![frm_donneesRH].VehiculePersoTranche1.Enabled = False
+  forms![frm_donneesRH].DistanceTranche2.Enabled = False
+  forms![frm_donneesRH].VehiculePersoTranche2.Enabled = False
+  forms![frm_donneesRH].FichierXml.Enabled = False
+  
+End Select
+
+
+End Sub

test/source/modules/exportDRH.bas

@@ -0,0 +1,101 @@
+Option Compare Database
+
+Public Sub Periple_MajTableTampon(ByVal CodeAgent As String, ByVal moisRH As Integer, ByVal anneeRH As Integer, Optional silencieux As Boolean = False)
+
+If IsNull(DFirst("Matricule", "tbl_Agents", "[CodeAgent]='" & CodeAgent & "'")) Then
+  MsgBox "Erreur: impossible de trouver le matricule de l'agent, impossible de créer le fichier d'export"
+  GoTo fin
+End If
+
+'vidage remplissage de la table PDE_PERIPLE
+DoCmd.SetWarnings False
+DoCmd.RunSQL "DELETE * FROM PDE_PERIPLE;"
+
+'la sous-requête (tbl_ImportRH) replace tbl_ImportRH, et filtre les lignes ne comprenant ni repas, ni kilomètres
+sql = "INSERT INTO PDE_PERIPLE ( IDF_AGENT, DATE_DEMANDE, MOTIF_DEPLACEMENT, ITINERAIRE, CP_DEP, DATE_DEPART, DATE_RETOUR, MOYEN_TRANSPORT, NB_KM_PARCOURUS, NBR_REPAS_PLEIN ) " & _
+      "SELECT tbl_Agents.Matricule AS IDF_AGENT, Date() AS DATE_DEMANDE, 'Travaux chantier' AS MOTIF_DEPLACEMENT, Last([ResidenceAdmin] & '-' & [LOCALISATION]) AS ITINERAIRE, Last(Left([CodeLocalisation],5)) AS CP_DEP, " & _
+      "CDate(CStr([DateRH]) & ' 07:30') AS DATE_DEPART, CDate(CStr([DateRH]) & ' 16:30') AS DATE_RETOUR, IIf([VehiculePersoTranche1]='True' Or [VehiculePersoTranche2]='True','Véhicule personnel','Véhicule de service') AS MOYEN_TRANSPORT,  " & _
+      "Sum((IIf([VehiculePersoTranche1]='True',CLng([DistanceTranche1]),0)+IIf([VehiculePersoTranche2]='True',CLng([DistanceTranche2]),0))) AS NB_KM_PARCOURUS, Sum(tbl_ImportRH.Repas) AS NBR_REPAS_PLEIN " & _
+      "FROM (SELECT tbl_ImportRH.* FROM tbl_ImportRH WHERE (cint([Repas])>0 or (IIf([VehiculePersoTranche1]='True',CLng([DistanceTranche1]),0)+IIf([VehiculePersoTranche2]='True',CLng([DistanceTranche2]),0))>0)) AS tbl_ImportRH " & _
+      "INNER JOIN tbl_Agents ON tbl_ImportRH.CodeAgent = tbl_Agents.CodeAgent GROUP BY tbl_Agents.Matricule, Date(), 'Travaux chantier', CDate(CStr([DateRH]) & ' 07:30'), CDate(CStr([DateRH]) & ' 16:30'), " & _
+      "IIf([VehiculePersoTranche1]='True' Or [VehiculePersoTranche2]='True','Véhicule personnel','Véhicule de service'),  tbl_ImportRH.CodeAgent, Month([DateRH]), Year([daterh]) " & _
+      "HAVING (((tbl_ImportRH.CodeAgent)='" & CodeAgent & "') AND ((Month([DateRH]))=" & moisRH & ") AND ((Year([daterh]))=" & anneeRH & ")) " & _
+      "ORDER BY CDate(CStr([DateRH]) & ' 07:30');"
+
+'Debug.Print sql
+'GoTo fin
+DoCmd.RunSQL sql
+DoCmd.SetWarnings True
+
+If DCount("IDF_AGENT", "PDE_PERIPLE", "") > 0 Then
+  If silencieux Then
+    Call Periple_ExportXML(True)
+  Else
+    DoCmd.OpenForm "frm_ValidationDonneesPeriple"
+  End If
+Else
+  MsgBox "Aucune données à exporter"
+End If
+
+fin:
+End Sub
+
+Public Sub Periple_ExportXML(silencieux As Boolean)
+On Error GoTo err
+Dim rep, nomFichier As String
+Dim repHttp, lecteurVirtuel As String
+Dim essai As Integer
+
+   'création du xml
+   rep = get_lien("tmp_xml")
+   nomFichier = DFirst("IDF_AGENT", "PDE_PERIPLE", "") & "_" & Format(Month(DFirst("DATE_DEPART", "PDE_PERIPLE", "")), "00") & Year(DFirst("DATE_DEPART", "PDE_PERIPLE", "")) & ".xml"
+   
+   If dir(rep, vbDirectory) = "" Then MkDir rep
+   If dir(rep & nomFichier) <> "" Then
+     Kill rep & nomFichier
+   End If
+   
+   Application.ExportXML acExportTable, "PDE_PERIPLE", rep & nomFichier
+   Call Attendre(100)
+
+   'test de connexion au sharepoint et mappage
+   repHttp = Nz(DLookup("valeur", "tbl_parametre", "[parametre]='repExport_xml'"), "")
+   lecteurVirtuel = Nz(DLookup("valeur", "tbl_parametre", "[parametre]='lecteurVirtuel'"), "")
+   
+   essai = 0
+   While testConnexionLecteur(lecteurVirtuel, repHttp) = False
+      Call Attendre(500)
+      essai = essai + 1
+      If essai >= 3 Then
+        If Not silencieux Then MsgBox "Erreur: impossible de se connecter au serveur sharepoint, le fichier a été créé ici: " & vbNewLine & _
+                                      rep & nomFichier
+        GoTo fin
+      End If
+   Wend
+   
+   If dir(lecteurVirtuel & "\", vbDirectory) = "" Then 'au cas où il serait séjà mappé
+     Set objReseau = CreateObject("WScript.Network")
+     objReseau.MapNetworkdrive lecteurVirtuel, repHttp
+   End If
+   
+   If dir(lecteurVirtuel & "\" & nomFichier) <> "" Then
+     If Not silencieux Then
+       If MsgBox("Un fichier portant ce nom existe déjà sur la sharepoint, voulez-vous le remplacer?", vbYesNo) = vbNo Then GoTo fin
+     End If
+     Kill lecteurVirtuel & "\" & nomFichier
+   End If
+   
+   Call FileCopy(rep & nomFichier, lecteurVirtuel & "\" & nomFichier)
+   
+   objReseau.RemoveNetworkDrive lecteurVirtuel, True
+   Set objReseau = Nothing
+
+fin:
+  Exit Sub
+annule:
+  MsgBox "Opération annulée"
+  GoTo fin
+err:
+  MsgBox "Une erreur s'est produite, veuillez contacter un administrateur" & vbNewLine & err.Description
+  GoTo fin
+End Sub

test/source/modules/sharepoint.bas

@@ -0,0 +1,42 @@
+Option Compare Database
+Option Explicit
+
+Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
+                                           "URLDownloadToFileA" ( _
+                                           ByVal pCaller As Long, ByVal szURL As String, _
+                                           ByVal szFileName As String, _
+                                           ByVal dwReserved As Long, _
+                                           ByVal lpfnCB As Long) As Long
+
+
+Sub DownloadFileFromWeb()
+Dim i As Integer
+
+    Const strUrl As String = "http://backweb.bas-rhin.fr/perstein/parc-erstein/export/201407FISCHERAlain.xml"
+    Dim strSavePath As String
+    Dim returnValue As Long
+    
+    strSavePath = "C:\temp_\xml_2708.xml"
+    returnValue = URLDownloadToFile(0, strUrl, strSavePath, 0, 0)
+    
+End Sub
+
+Public Function testConnexionLecteur(ByVal lecteurVirtuel As String, ByVal repHttp As String) As Boolean
+On Error GoTo fin
+Dim essai As Integer
+Dim objFSO, objReseau As Object
+
+testConnexionLecteur = False
+Set objReseau = CreateObject("WScript.Network")
+If dir(lecteurVirtuel & "\", vbDirectory) <> "" Then
+  'déjà mappé
+Else
+  objReseau.MapNetworkdrive lecteurVirtuel, repHttp
+End If
+testConnexionLecteur = True
+
+objReseau.RemoveNetworkDrive lecteurVirtuel, True
+fin:
+Set objReseau = Nothing
+
+End Function

test/source/queries/a_test.bas

@@ -0,0 +1,122 @@
+Operation =1
+Option =0
+Begin InputTables
+    Name ="Rapport"
+End
+Begin OutputColumns
+    Expression ="Rapport.*"
+End
+Begin OrderBy
+    Expression ="Rapport.Id"
+    Flag =0
+End
+dbBoolean "ReturnsRecords" ="-1"
+dbInteger "ODBCTimeout" ="60"
+dbByte "RecordsetType" ="0"
+dbBoolean "OrderByOn" ="0"
+dbByte "Orientation" ="0"
+dbByte "DefaultView" ="2"
+dbBoolean "FilterOnLoad" ="0"
+dbBoolean "OrderByOnLoad" ="-1"
+dbBoolean "TotalsRow" ="0"
+Begin
+    Begin
+        dbText "Name" ="Rapport.Id"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.CodeAttelage"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.CodeAgent"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.CodeChantier"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.Duree"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.DateDebut"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.DateFin"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.CodeNatureRealisation"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.CodeLocalisation"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.Remarque"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.HeureSup1"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.HeureSup2"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.HeureSupDimanche"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.Repas"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.DistanceTranche1"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.VehiculePersoTranche1"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.DistanceTranche2"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.VehiculePersoTranche2"
+        dbLong "AggregateType" ="-1"
+    End
+    Begin
+        dbText "Name" ="Rapport.Depart"
+        dbLong "AggregateType" ="-1"
+    End
+End
+Begin
+    State =0
+    Left =0
+    Top =0
+    Right =735
+    Bottom =840
+    Left =-1
+    Top =-1
+    Right =719
+    Bottom =544
+    Left =0
+    Top =0
+    ColumnsShown =539
+    Begin
+        Left =48
+        Top =12
+        Right =192
+        Bottom =156
+        Top =0
+        Name ="Rapport"
+        Name =""
+    End
+End

test/source/references.csv

@@ -0,0 +1,6 @@
+{00062FFF-0000-0000-C000-000000000046},9,4
+{B691E011-1797-432E-907A-4D8C69339129},6,1
+{00000300-0000-0010-8000-00AA006D2EA4},6,0
+{00020430-0000-0000-C000-000000000046},2,0
+{4AC9E1DA-5BAD-4AC7-86E3-24F4CDCECA28},12,0
+{00020905-0000-0000-C000-000000000046},8,5

test/source/reports/et_test.bas

@@ -0,0 +1,94 @@
+Version =20
+VersionRequired =20
+Begin Report
+    LayoutForPrint = NotDefault
+    DividingLines = NotDefault
+    AllowDesignChanges = NotDefault
+    DateGrouping =1
+    GrpKeepTogether =1
+    PictureAlignment =2
+    DatasheetGridlinesBehavior =3
+    GridY =10
+    Width =6994
+    DatasheetFontHeight =11
+    ItemSuffix =1
+    DatasheetGridlinesColor =14806254
+    RecSrcDt = Begin
+        0x8a407fe5d5d3e440
+    End
+    DatasheetFontName ="Calibri"
+    PrtMip = Begin
+        0x6801000068010000680100006801000000000000201c0000e010000001000000 ,
+        0x010000006801000000000000a10700000100000001000000
+    End
+    FilterOnLoad =0
+    FitToPage =1
+    DisplayOnSharePointSite =1
+    DatasheetAlternateBackColor =15921906
+    DatasheetGridlinesColor12 =0
+    FitToScreen =1
+    DatasheetBackThemeColorIndex =1
+    BorderThemeColorIndex =3
+    ThemeFontIndex =1
+    ForeThemeColorIndex =0
+    AlternateBackThemeColorIndex =1
+    AlternateBackShade =95.0
+    Begin
+        Begin Label
+            BackStyle =0
+            FontSize =11
+            FontName ="Calibri"
+            ThemeFontIndex =1
+            BackThemeColorIndex =1
+            BorderThemeColorIndex =0
+            BorderTint =50.0
+            ForeThemeColorIndex =0
+            ForeTint =50.0
+            GridlineThemeColorIndex =1
+            GridlineShade =65.0
+        End
+        Begin PageHeader
+            Height =1134
+            Name ="ZoneEntêtePage"
+            AutoHeight =1
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+            BackThemeColorIndex =1
+            Begin
+                Begin Label
+                    Left =2154
+                    Top =170
+                    Width =2211
+                    Height =567
+                    BorderColor =8355711
+                    ForeColor =8355711
+                    Name ="Étiquette0"
+                    Caption ="test 11/10/16"
+                    GridlineColor =10921638
+                    LayoutCachedLeft =2154
+                    LayoutCachedTop =170
+                    LayoutCachedWidth =4365
+                    LayoutCachedHeight =737
+                End
+            End
+        End
+        Begin Section
+            KeepTogether = NotDefault
+            Height =5952
+            Name ="Détail"
+            AutoHeight =1
+            AlternateBackColor =15921906
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+            BackThemeColorIndex =1
+        End
+        Begin PageFooter
+            Height =1134
+            Name ="ZonePiedPage"
+            AutoHeight =1
+            AlternateBackThemeColorIndex =1
+            AlternateBackShade =95.0
+            BackThemeColorIndex =1
+        End
+    End
+End

test/source/reports/et_test.pv

@@ -0,0 +1,5 @@
+1
+9
+2970
+2100
+0

test/source/tbldef/ArrayOfAction.sql

@@ -0,0 +1,3 @@
+CREATE TABLE [ArrayOfAction] (
+  [ArrayOfConges] VARCHAR (255)
+)

test/source/tbldef/tmp_problemes.sql

@@ -0,0 +1,5 @@
+CREATE TABLE [tmp_problemes] (
+  [Erreur] VARCHAR (255),
+  [ObjetConcerne] VARCHAR (255),
+  [Detail] VARCHAR (255)
+)