openaccess/test/source/modules/ChargementAppli.bas

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