Option Compare Database

' ** Access Toolbox Module **
' on 2017-02-28,
' @author: Olivier Massot
' V 1.0

' Manage external databases

Public Function EtatModeConnexion() As String
  On Error GoTo err
  'renvoie le mode de connexion actuel, ou une chaine vide si celui-ci ne peut être determiné
  Dim table As DAO.TableDef
  Dim modeConnexion, dirConnexionTable, modeConnexionTable As String
  Dim compte, compteErr As Integer
  'à noter: dans la table des bases dorsales, mode de connexion = '*' pour que cette base soit ignorée lors des tests
  
  modeConnexion = ""
  If Not tableExiste("ztblBasesDorsales") Then GoTo errZtbl
  
  For Each table In CurrentDb.TableDefs
    If Len(table.Connect) > 0 Then
      dirConnexionTable = replace(table.Connect, ";DATABASE=", "")
      modeConnexionTable = Nz(DFirst("Mode", "ztblBasesDorsales", "[NomBase]='" & extraitNomFichier(dirConnexionTable) & "' AND [rep]='" & repFichier(dirConnexionTable) & "'"), "")
      If modeConnexionTable = "*" Then
        'on passe à la suite
      ElseIf Len(modeConnexionTable) > 0 Then
        'c'est une table liée
        If Len(modeConnexion) = 0 Then
          modeConnexion = modeConnexionTable
        Else
          If modeConnexion <> modeConnexionTable Then GoTo errConnexionsIncoherentes
        End If
      Else
        GoTo errBaseIntrouvable
      End If
    End If
  Next table
  EtatModeConnexion = modeConnexion
fin:
    Exit Function
err:
   MsgBox "Erreur lors de la détermination du mode de connexion:" & vbNewLine & err.Description
   GoTo fin
errZtbl:
   MsgBox "Erreur lors de la détermination du mode de connexion:" & vbNewLine & "La table ztblBasesDorsales est manquante"
   GoTo fin
errBaseIntrouvable:
   MsgBox "Erreur lors de la détermination du mode de connexion:" & vbNewLine & "La base d'une table est introuvable dans ztblBasesDorsales"
   GoTo fin
errConnexionsIncoherentes:
   MsgBox "Erreur lors de la détermination du mode de connexion:" & vbNewLine & "Connexions incohérentes détectées"
   GoTo fin
End Function

Public Sub choisirModeConnexion()
On Error GoTo err
  If Not tableExiste("ztblBasesDorsales") Then GoTo errZtbl
  If Not formExiste("zfrmBasesDorsales") Then GoTo errZfrm

  DoCmd.OpenForm "zfrmBasesDorsales"
  
fin:
Exit Sub
err:
  MsgBox "Erreur en cours de procédure:" & err.Description
  GoTo fin
errZtbl:
  MsgBox "Erreur: la table ztblBasesDorsales est nécessaire (cf. FonctionsCommunes.accdb)"
  GoTo fin
errZfrm:
  MsgBox "Erreur: le formulaire zfrmBasesDorsales est nécessaire (cf. FonctionsCommunes.accdb)"
  GoTo fin
End Sub

Public Function majConnectionsAppli(ByVal mode As String) As Boolean
'met à jour les connections de toutes les tables
  Dim table As DAO.TableDef
  Dim compte, compteOK As Integer
  compte = 0
  compteOK = 0
  
  majConnectionsAppli = False
  
  If Not tableExiste("ztblBasesDorsales") Then GoTo errZtbl
  If Not formExiste("zfrmBasesDorsales") Then GoTo errZfrm
  Application.Echo False
  DoCmd.Hourglass True
  
  If modeValide(mode) = False Then GoTo errModeNonValide
  
  For Each table In CurrentDb.TableDefs
    If Len(table.Connect) > 0 Then
      'c'est une table liée
      compte = compte + 1
      If ConnectMdb(table.name, mode, True) = True Then compteOK = compteOK + 1
    End If
  Next table
If compteOK <> compte Then GoTo errErreursDetectees

majConnectionsAppli = True
Application.Echo True
MsgBox "Opération terminée"
fin:
  Application.Echo True
  DoCmd.Hourglass False
  Exit Function
err:
  MsgBox "Erreur en cours de procédure:" & err.Description
  GoTo fin
errZtbl:
  MsgBox "Erreur: la table ztblBasesDorsales est nécessaire (cf. FonctionsCommunes.accdb)"
  GoTo fin
errZfrm:
  MsgBox "Erreur: le formulaire zfrmBasesDorsales est nécessaire (cf. FonctionsCommunes.accdb)"
  GoTo fin
errErreursDetectees:
  MsgBox "Erreur: certaines attaches ne sembles pas avoir été mises à jour correctement"
  GoTo fin
errModeNonValide:
  MsgBox "Erreur: ce mode n'est pas reconnu"
  GoTo fin
End Function

Private Function ConnectMdb(ByVal tbl As String, ByVal mode As String, Optional silencieuse As Boolean = False) As Boolean
'met à jour la connexion de la table selon le mode de branchement demandé
On Error GoTo err
Dim bdd As DAO.Database
Dim td As DAO.TableDef
Dim connexion, nouveauRep, fichier As String
ConnectMdb = False

If Not tableExiste(tbl) Then GoTo errTableManq

Set bdd = CurrentDb
Set td = bdd.TableDefs(tbl)

connexion = Nz(td.Connect, "")       'etat de la connexion actuelle
If Len(connexion) = 0 Then GoTo errMajLien

fichier = extraitNomFichier(connexion)
If Nz(DFirst("Mode", "ztblBasesDorsales", "[NomBase]='" & fichier & "'"), "") = "*" Then GoTo reussite
nouveauRep = Nz(DFirst("Rep", "ztblBasesDorsales", "[Mode]='" & mode & "' and [NomBase]='" & fichier & "'"), "")
If Len(nouveauRep) = 0 Or Dir(nouveauRep, vbDirectory) = "" Then GoTo errRep
If Right(nouveauRep, 1) <> "\" Then nouveauRep = nouveauRep & "\"

' Modifie la propriété Connect avec la nouvelle chaîne de connexion
 td.Connect = ";DATABASE=" & nouveauRep & fichier
'Met à jour la liaison
 td.RefreshLink
 
reussite:
 ConnectMdb = True
fin:
  If Len(msgErr) > 0 Then
    If silencieuse = True Then
      Debug.Print msgErr
    Else
      MsgBox msgErr
    End If
  End If
  Set td = Nothing
  Set db = Nothing
  Exit Function
errTableManq:
  msgErr = "Impossible de mettre à jour la connexion de " & tbl & ": table introuvable"
  GoTo fin
err:
  msgErr = "Impossible de mettre à jour la connexion de " & tbl & ": " & err.Description
  GoTo fin
errMajLien:
  msgErr = "Impossible de mettre à jour la connexion de " & tbl & ": impossible de déterminer l'état actuel de la connexion de la table, ce n'est peut-être pas une table liée"
  GoTo fin
errRep:
  msgErr = "Impossible de mettre à jour la connexion de " & tbl & ": répertoire cible invalide"
  GoTo fin
End Function

Private Function modeValide(ByVal mode As String) As Boolean
On Error GoTo fin
  modeValide = False
  modeValide = (DCount("Mode", "ztblBasesDorsales", "[Mode]='" & mode & "'") > 0)
fin:
End Function

Public Function modeConnexionParDefaut()
On Error GoTo fin
  modeConnexionParDefaut = ""
  modeConnexionParDefaut = Nz(DFirst("ModeDefaut", "ztblUtilisateurs", "[login]='" & CurrentUser & "'"), "")
fin:
End Function