Attribute VB_Name = "Vérifier attaches"
Type Get_Param
ChaineRetournée As String
Rc As Boolean
reasonCode As ErrObject
End Type

Function TrouverAccueil(chCheminRecherche) As MSA_OUVRIRNOMFICHIER
    ' Affiche une boîte de dialogue d'ouverture de fichier pour permettre
' à l'utilisateur de rechercher la base de données Accueil.
' Retourne le chemin complet de Accueil.
    
    Dim msaof As MSA_OUVRIRNOMFICHIER
    
    ' Définit les options de la boîte de dialogue.
    msaof.chTitreDialogue = "Où se trouve la base de donnée Accueil ?"
    msaof.chRépInitial = chCheminRecherche
    msaof.chFiltre = MSA_CréerChaîneFiltre("Bases de données", "*.dbf")
    
    ' Appelle la routine de dialogue Ouvrir fichier.
    MSA_DonnerNomFichierOuvert msaof
    
    ' Retourne le chemin et le nom du fichier.
    
    TrouverAccueil = msaof
End Function


Function MSA_CréerChaîneFiltre(ParamArray varFilt() As Variant) As String
' Crée une chaîne de filtre à partir des paramètres fournis.
' Retourne "" si aucun argument n'est passé.
' Nombre pair d'arguments attendu (nom filtre, extension), mais si un
' nombre impair d'argument est fourni, *.* est ajouté.
    
    Dim chFiltre As String
    Dim entRet As Integer
    Dim entNum As Integer

    entNum = UBound(varFilt)
    If (entNum <> -1) Then
        For entRet = 0 To entNum
            chFiltre = chFiltre & varFilt(entRet) & vbNullChar
        Next
        If entNum Mod 2 = 0 Then
            chFiltre = chFiltre & "*.*" & vbNullChar
        End If
        chFiltre = chFiltre & vbNullChar
    
    Else
        chFiltre = ""
    End If

    MSA_CréerChaîneFiltre = chFiltre
End Function

Function MSA_ConvertirChaîneFiltre(chFiltreIn As String) As String
' Crée une chaîne filtre à partir d'un barre ("|") séparée de la chaîne.
' La chaîne ira par paire de chaînes filtre|extension
' i.e. "Bases de données Access|*.mdb|Tous les fichiers|*.*"
' Si il n'existe pas d'extensions pour la dernière paire de filtre,*.* est ajouté.
' Ce code ignorera les chaînes vides, i.e. les paires "||".
' Retourne "" si les chaînes passées en argument sont vides.

    Dim chFiltre As String
    Dim entNum As Integer, entPos As Integer, entDernièrePos As Integer

    chFiltre = ""
    entNum = 0
    entPos = 1
    entDernièrePos = 1

    ' Ajouter des chaînes tant que l'on trouve des barres.
    ' Ignorer toutes les chaînes vides (non permises).
    Do
        entPos = InStr(entDernièrePos, chFiltreIn, "|")
        If (entPos > entDernièrePos) Then
            chFiltre = chFiltre & Mid(chFiltreIn, entDernièrePos, entPos - entDernièrePos) & vbNullChar
            entNum = entNum + 1
            entDernièrePos = entPos + 1
        ElseIf (entPos = entDernièrePos) Then
            entDernièrePos = entPos + 1
        End If
    Loop Until (entPos = 0)
        
    ' Obtenir la dernière chaîne si elle existe.
    ' Vérifier que chFiltreIn n'est pas terminé par une barre.
    entPos = Len(chFiltreIn)
    If (entPos >= entDernièrePos) Then
        chFiltre = chFiltre & Mid(chFiltreIn, entDernièrePos, entPos - entDernièrePos + 1) & vbNullChar
        entNum = entNum + 1
    End If
    
    ' Ajouter *.* s'il n'y a pas d'extension pour la dernière chaîne.
    If entNum Mod 2 = 1 Then
        chFiltre = chFiltre & "*.*" & vbNullChar
    End If
    
    ' Et terminer par Null si on a une filtre.
    If chFiltre <> "" Then
        chFiltre = chFiltre & vbNullChar
    End If
    
    MSA_ConvertirChaîneFiltre = chFiltre
End Function


Private Function MSA_DonnerNomFichierSauvé(msaof As MSA_OUVRIRNOMFICHIER) As Integer
' Ouvre le dialogue Enregistrer Fichier.
    
    Dim of As OUVRIRNOMFICHIER
    Dim entRet As Integer

    MSAOF_vers_OF msaof, of
    of.indicateurs = of.indicateurs Or OFN_MASQUERLECTURESEULE
    entRet = DonnerNomFichierSauvé(of)
    If entRet Then
        OF_vers_MSAOF of, msaof
    End If
    MSA_DonnerNomFichierSauvé = entRet
End Function

Function MSA_DonnerNomFichierSauvéSimple() As String
' Ouvre le dialogue Enregistrer Fichier avec les valeurs par défaut.

    Dim msaof As MSA_OUVRIRNOMFICHIER
    Dim entRet As Integer
    Dim chRet As String
    
    entRet = MSA_DonnerNomFichierSauvé(msaof)
    If entRet Then
        chRet = msaof.chCheminCompletRetourné
    End If
    
    MSA_DonnerNomFichierSauvéSimple = chRet
End Function

Private Function MSA_DonnerNomFichierOuvert(msaof As MSA_OUVRIRNOMFICHIER) As Integer
' Ouvre le dialogue Ouvrir fichier.
    
    Dim of As OUVRIRNOMFICHIER
    Dim entRet As Integer

    MSAOF_vers_OF msaof, of
    entRet = DonnerNomFichierOuvert(of)
    If entRet Then
        OF_vers_MSAOF of, msaof
    End If
    MSA_DonnerNomFichierOuvert = entRet
End Function

Function MSA_DonnerNomFichierOuvertSimple() As String
' Ouvre la boîte de dialogue Ouvrir avec les valeurs par défaut.

    Dim msaof As MSA_OUVRIRNOMFICHIER
    Dim entRet As Integer
    Dim chRet As String
    
    entRet = MSA_DonnerNomFichierOuvert(msaof)
    If entRet Then
        chRet = msaof.chCheminCompletRetourné
    End If
    
    MSA_DonnerNomFichierOuvertSimple = chRet
End Function

Public Function VérifierAttaches() As Boolean
' Vérifie les attaches à la base de données Accueil; retourne
' vrai si tout va bien.
    
 
    ' Ouvre une table attachée pour vérifier si l'information de connexion
    ' est correcte.

    ' S'il n'y a pas d'erreur, retourne Vrai.
  Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset
   
    ' Ouvre une base de données Microsoft Jet à
    ' laquelle vous pourrez attacher une table.
 
     Set dbsTemp = CurrentDb
     strCurrentDbName = dbsTemp.Name
     Set Cnn = New ADODB.Connection
     Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
     Cnn.Open strCurrentDbName, "admin", ""
   
     On Error Resume Next

    Set rstTemp = Cnn.Execute("SELECT count (*) FROM accueil ;")
    
    If Err = 0 Then
        VérifierAttaches = True
    Else
        VérifierAttaches = False
    End If
rstTemp.Close
Cnn.Close

End Function

Private Sub OF_vers_MSAOF(of As OUVRIRNOMFICHIER, msaof As MSA_OUVRIRNOMFICHIER)
' Cette routine convertit la structure win32 en structure MSAccess.
    
    msaof.chCheminCompletRetourné = Left$(of.lpstrFichier, InStr(of.lpstrFichier, vbNullChar) - 1)
    msaof.chNomFichierRetourné = of.lpstrTitreFichier
    msaof.entPartieFichier = of.nPartieFichier
    msaof.entExtensionFichier = of.nExtensionFichier
    
End Sub


Private Sub MSAOF_vers_OF(msaof As MSA_OUVRIRNOMFICHIER, of As OUVRIRNOMFICHIER)
' Cette fonction convertit la structure MSAccess en structure win32.
    
    Dim chFichier As String * 512

    ' Initialise des parcelles de la structure.
    of.hwndPropriétaire = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrFiltrePersonnalisé = 0
    of.nFiltrePersonMax = 0
    of.lpfnCrochet = 0
    of.lpNomModèle = 0
    of.lDonnéesClient = 0

    If msaof.chFiltre = "" Then
        of.lpstrFiltre = MSA_CréerChaîneFiltre(TOUSFICHIERS)
    Else
        of.lpstrFiltre = msaof.chFiltre
    End If
    of.nIndexFiltre = msaof.lngIndexFiltre

    of.lpstrFichier = msaof.chFichierInitial & String(512 - Len(msaof.chFichierInitial), 0)
    of.nFichierMax = 511
    
    of.lpstrTitreFichier = String(512, 0)
    of.nTitreFichierMax = 511
    
    of.lpstrTitre = msaof.chTitreDialogue
    
    of.lpstrRépInitial = msaof.chRépInitial
   
    of.lpstrExtDéf = msaof.chExtensionDéfaut
    
    of.indicateurs = msaof.lngIndicateurs
    
    of.lTailleStruct = Len(of)
    
End Sub

Private Function ActualiserAttaches(chNomFichier As String) As Boolean
' Raffraichit les liens à la base de données spécifiée.
' Retourne Vrai si tout s'est bien passé.

    Dim bds As Database
    Dim tdf As TableDef

    ' Boucle sur toutes les tables de la base de données.
    Set bds = CurrentDb()
    For Each tdf In bds.TableDefs
        ' Si la table a une chaîne de connection, c'est une table attachée.
        If Len(tdf.connect) > 0 Then
          ' tdf.connect = ";DATABASE=" & chNomFichier
          ' tdf.SourceTableName = chNomFichier

            Err = 0
            On Error Resume Next
            tdf.RefreshLink ' Relie les tables
            If Err <> 0 Then
                ActualiserAttaches = False
                Exit Function
            End If
        End If
    Next tdf
    
    ActualiserAttaches = True     ' Liens complets
    
End Function

Public Function RattacherTables() As Boolean
' Essaie d'actualiser les liens à la base de données Accueil.
' Retourne Vrai si tout s'est bien passé.

    Dim chRépAcc As String
    Dim chCheminRecherche As String
    Dim chNomFichier As String
    Dim entErreur As Integer
    Dim chErreur As String
    
    Const conTablesMax = 8
    Const conTableInexistante = 3011
    Const conPasAccueil = 3078
    Const conAccueilNonTrouvé = 3024
    Const conAccèsRefusé = 3051
    Const conBaseDonnéesLectureSeule = 3027
    Const conTitreApp = "l'application ACCUEIL DES REFUGIES"

    ' Obtient le nom du répertoire où se trouve Msaccess.exe.
    chRépAcc = SysCmd(acSysCmdAccessDir)

    ' Obtient le chemin des bases de données exemple par défaut.
    If Dir$(chRépAcc & "Exemples\.") = "" Then
        chCheminRecherche = chRépAcc
    Else
        chCheminRecherche = chRépAcc & "Exemples\"
    End If

    ' Recherhe la base de données Accueil.
    If (Dir$(chCheminRecherche & "Accueil.mdb") <> "") Then
        chNomFichier = chCheminRecherche & "Accueil.mdb"
    Else
        ' Ne peut pas trouver Accueil, affiche alors le dialogue Ouvrir fichier.
        MsgBox "Impossible de trouver les tables attachées dans la base de données Accueil. Vous devez rechercher Accueil pour utiliser " _
            & conTitreApp & ".", vbExclamation
        chNomFichier = Trim(TrouverAccueil(chCheminRecherche).chCheminCompletRetourné)
        If chNomFichier = "" Then
            chErreur = "Désolé, vous devez rechercher Accueil pour ouvrir " & conTitreApp & "."
            GoTo Quitte_Echec
        End If
    End If

    ' Répare les attaches.
    If ActualiserAttaches(chNomFichier) Then   ' Tout va bien!
        RattacherTables = True
        Exit Function
    End If
    
    ' Si échec, affiche une erreur.
    Select Case Err
    Case conTableInexistante, conPasAccueil
        chErreur = "Le fichier '" & chNomFichier & "' ne contient pas les tables Accueil nécessaires."
    Case Err = conAccueilNonTrouvé
        chErreur = "Vous ne pouvez pas exécuter " & conTitreApp & " tant que la base de données Accueil n'est pas trouvée."
    Case Err = conAccèsRefusé
        chErreur = "Impossible d'ouvrir " & chNomFichier & " du fait que celui-ci est en lecture seule ou bien est partagé en lecture seule."
    Case Err = conBaseDonnéesLectureSeule
        chErreur = "Impossible de rattacher les tables du fait que " & conTitreApp & " est en lecture seule ou bien est partagée en lecture seule."
    Case Else
        chErreur = Err.Description
    End Select
    
Quitte_Echec:
    MsgBox chErreur, vbCritical
    RattacherTables = False
    
End Function
Function GetParam(clé_rech As String) As Get_Param
     
    Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset
   
    ' Ouvre une base de données Microsoft Jet à
    ' laquelle vous pourrez attacher une table.
 
     Set dbsTemp = CurrentDb
     strCurrentDbName = dbsTemp.Name
     Set Cnn = New ADODB.Connection
     Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
     Cnn.Open strCurrentDbName, "admin", ""

    Set rstTemp = Cnn.Execute("SELECT Paramètres.* FROM Paramètres WHERE Paramètres.Nom_param='" & clé_rech & "';")
      
      If rstTemp.EOF Then
    
    GetParam.Rc = False
    Set GetParam.reasonCode = Err
    Else
    GetParam.ChaineRetournée = rstTemp!valeur_param
    GetParam.Rc = True
            
    End If
rstTemp.Close
Cnn.Close
End Function
Function UpdParam(clé_rech As String, Nouv_Val As String) As Boolean
'--------------------------------------------------------------------------------
' Mise à jour dans la table paramètre d'une nouvelle valeur sur une clé existante
'--------------------------------------------------------------------------------

   
    Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset
   
    ' Ouvre une base de données Microsoft Jet à
    ' laquelle vous pourrez attacher une table.
 
     Set dbsTemp = CurrentDb
     strCurrentDbName = dbsTemp.Name
     Set Cnn = New ADODB.Connection
     Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
     Cnn.Open strCurrentDbName, "admin", ""

    Set rstTemp = Cnn.Execute("UPDATE Paramètres SET valeur_param = '" & Nouv_Val & "' WHERE Nom_param='" & clé_rech & "';")
      
    If Err = 0 Then
         UpdParam = True
    Else
        MsgBox Err.Description
        UpdParam = False
    End If
'rstTemp.Close
Cnn.Close
End Function
Function PutParam(clé_rech As String, Nouv_Val As String) As Boolean
'--------------------------------------------------------------------------------
' Insertion dans la table paramètre d'une nouvelle valeur
'--------------------------------------------------------------------------------
     
    Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset
   
    ' Ouvre une base de données Microsoft Jet à
    ' laquelle vous pourrez attacher une table.
 
    On Error Resume Next
     
     Set dbsTemp = CurrentDb
     strCurrentDbName = dbsTemp.Name
     Set Cnn = New ADODB.Connection
     Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
     Cnn.Open strCurrentDbName, "admin", ""
     Set rstTemp = Cnn.Execute("INSERT INTO Paramètres (Nom_param, valeur_param) VALUES ('" & clé_rech & "', '" & Nouv_Val & "');")
      
    If Err = 0 Then
         PutParam = True
    Else
        MsgBox Err.Description
        PutParam = False
    End If
rstTemp.Close
Cnn.Close
End Function


Sub ConnectX()

    Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset
    Dim strMenu, strCurrentDbName As String
    Dim RetCherchAccueil As MSA_OUVRIRNOMFICHIER
    Dim dirTab As String
    Dim NomTab As String
    Dim RcCherchAccueil As Boolean
    
    Set dbsTemp = CurrentDb
    If GetParam("RepTableLiée").Rc = True Then
        dirTab = GetParam("RepTableLiée").ChaineRetournée
    Else
        GoTo cherche_accueil
    End If
    If GetParam("NomTableLiée").Rc = True Then
       NomTab = GetParam("NomTableLiée").ChaineRetournée
    Else
        GoTo cherche_accueil
    End If
    If VérifierAttaches() = True Then
        InfoTabAttache = "La base cible est " & dirTab & "\" & NomTab & ".dbf"
        GoTo fin
    End If

' Appelle la procédure ConnectOutput. Le troisième
    ' argument sera utilisé comme chaîne Connect,
    ' et le quatrième comme SourceTableName.
    If Len(Dir$(dirTab & "\" & NomTab & ".dbf")) > 0 Then
        rc_connect = ConnectOutput(dbsTemp, _
                    "dBASEtable", _
                    "dBASE 5.0;DATABASE=" & dirTab, _
                    NomTab)
        If rc_connect = False Then
           GoTo cherche_accueil
        Else
        InfoTabAttache = "La base cible est " & dirTab & "\" & NomTab & ".dbf"
            GoTo fin
        End If
    Else
        GoTo cherche_accueil
    End If

'-----------------------------------------------------------
' Base liée introuvable, on la recherche dans le répertoire
'-----------------------------------------------------------
cherche_accueil:
    rc_connect = False
    Do While rc_connect = False
        RetCherchAccueil = TrouverAccueil(dirTab)
        If Len(RetCherchAccueil.chCheminCompletRetourné) = 0 Then
            GoTo fin
        End If
        With RetCherchAccueil
            dirTab = Left(.chCheminCompletRetourné, (.entPartieFichier - 1))
            NomTab = Left(.chNomFichierRetourné, (.entExtensionFichier - .entPartieFichier - 1))
        End With
        rc_connect = ConnectOutput(dbsTemp, _
                    "dBASEtable", _
                    "dBASE 5.0;DATABASE=" & dirTab, _
                    NomTab)
    Loop
    
    '
    ' Mise à jour de la table paramètre pour les connexions suivantes
    '
    If GetParam("RepTableLiée").Rc = True Then
        RcCherchAccueil = UpdParam("RepTableLiée", dirTab)
    Else
        RcCherchAccueil = PutParam("RepTableLiée", dirTab)
    End If
    If GetParam("NomTableLiée").Rc = True Then
       RcCherchAccueil = UpdParam("NomTableLiée", NomTab)
    Else
       RcCherchAccueil = PutParam("NomTableLiée", NomTab)
    End If
    InfoTabAttache = "La base cible est " & dirTab & "\" & NomTab & ".dbf"
   
fin:
    dbsTemp.Close
    
End Sub

Function ConnectOutput(dbsTemp As Database, _
    strTable As String, strConnect As String, _
    strSourceTable As String) As Boolean

    Dim tdfLinked As TableDef
    Dim rstLinked As Recordset
    Dim intTemp As Integer

    ' Crée un objet TableDef, définit ses propriétés
    ' Connect et SourceTableName en fonction des
    ' arguments passéset ajoute l'objet à la
    ' collection TableDefs.
    Set tdfLinked = dbsTemp.CreateTableDef(strTable)
    
    On Error Resume Next

    tdfLinked.connect = strConnect
    tdfLinked.SourceTableName = strSourceTable
    dbsTemp.TableDefs.Append tdfLinked
    
    If Err = 0 Then
        tdfLinked.Name = "Accueil"
        ConnectOutput = True
    Else
        ConnectOutput = False
    End If
 
    
End Function
Public Function SupprimerAttaches() As Boolean
' Supprime les liens à la base de données spécifiée.
' Retourne Vrai si tout s'est bien passé.

    Dim bds As Database
    Dim tdf As TableDef
    Dim dbsTemp As Database
    Dim Cnn As ADODB.Connection
    Dim rstTemp As ADODB.Recordset

    Set bds = CurrentDb()
    bds.TableDefs.Delete ("Accueil")
    
   
    ' Ouvre une base de données Microsoft Jet à
    ' laquelle vous pourrez attacher une table.

del0:
     Set dbsTemp = CurrentDb
     strCurrentDbName = dbsTemp.Name
     Set Cnn = New ADODB.Connection
     Cnn.Provider = "Microsoft.Jet.OLEDB.4.0"
     Cnn.Open strCurrentDbName, "admin", ""

    Set rstTemp = Cnn.Execute("SELECT Paramètres.* FROM Paramètres WHERE Paramètres.Nom_param='NomTableLiée';")
    If rstTemp.EOF Then
        GoTo del1
    End If
    rstTemp.Close
    Set rstTemp = Cnn.Execute("DELETE FROM Paramètres WHERE Paramètres.Nom_param='NomTableLiée';")
      
    If Err <> 0 Then
       MsgBox Err.Description
    End If

del1:
    Set rstTemp = Cnn.Execute("SELECT Paramètres.* FROM Paramètres WHERE Paramètres.Nom_param='RepTableLiée';")
    If rstTemp.EOF Then
        GoTo fin:
    End If
    rstTemp.Close
    Set rstTemp = Cnn.Execute("DELETE FROM Paramètres WHERE Paramètres.Nom_param='RepTableLiée';")
      
    If Err <> 0 Then
       MsgBox Err.Description
    End If

fin:
Cnn.Close

SupprimerAttaches = True     ' Liens supprimés


End Function

Sub toto()
Rc = SupprimerAttaches()
End Sub