openaccess/test/source/modules/exportDRH.bas

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