Tables: Rétablir un lien d'une table Access depuis le code	Author(s) Dev Ashish

Rétablir un lien d'une table Access depuis le code.

(Q)    Dans ma base de données, je possède plusieurs tables liées (attachées) à plusieurs bases de données en arrière plan.  Comment puis-je m'assurer que toutes les tables sont connectées lorsque j'ouvre la base de donnée d'avant-plan?

(A)    Vous pouvez traverser la collection TableDefs pour voir quelles tables possèdent une propriété  Connect.  Si cette propriété Connect est fournie, on peut reconnecter la table en utilisant cette spécification.

    Voici une fonction  (fRefreshLinks) que vous pourriez exécuter au démarrage.  Cette fonction examine chaque table dans la base de données actuelle et essaie de retrouver la source de données si la propriété mentionnée dans la propriété Connect, s'il y a lieu.

    Si la base de données mentionnée ne peut être retrouvée, le code fait appel au dialogue GetOpenFileName de sorte que l'utilisateur puisse spécifier une source alternative.

'***************** Code Start ***************
Function fRefreshLinks() As Boolean
Dim strMsg As String, collTbls As Collection
Dim i As Integer, strDBPath As String, strTbl As String
Dim dbCurr As DATABASE, dbLink As DATABASE
Dim tdfLocal As TableDef
Dim varRet As Variant
Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000

    On Local Error GoTo fRefreshLinks_Err

    If MsgBox("Are you sure you want to reconnect all Access tables?", _
            vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise
cERR_USERCANCEL

    'Premièrement, trouver toutes les tables liées, dans la collection
    Set collTbls = fGetLinkedTables

    'et maintenant, les relier
    Set dbCurr = CurrentDb

  strMsg = "Désirez-vous spécifier un chamin différent pour vos tables  Access?" 
If MsgBox(strMsg, vbQuestion + vbYesNo, "Source alternative de données...") = vbYes
Then  strNewPath = fGetMDBName("S.V.P., choisir une base de données")  Else 
strNewPath = vbNullString  End If

    For i = collTbls.Count To 1 Step -1
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")
        If Left$(strDBPath, 4) = "ODBC" Then
            'Tables ODBC
            'les tables ODBC sont manipulées différemment
           ' Set tdfLocal = dbCurr.TableDefs(strTbl)
           ' With tdfLocal
           '     .Connect = pcCONNECT
           '     .RefreshLink
           '     collTbls.Remove (strTbl)
           ' End With
        Else
            If strNewPath <> vbNullString Then
                'Essayer ceci en premier
                strDBPath = strNewPath
            Else
                If Len(Dir(strDBPath)) = 0 Then
                    'Le fichier n'existe pas, appeler GetOpenFileName
                    strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                    If strDBPath = vbNullString Then
                        'L'utilisateur annule en cliquant  cancel
                        Err.Raise cERR_USERCANCEL
                    End If
                End If
            End If

            'la base de données d'arrière-plan existe
            'On place ici, car on peut avoir plusieurs sources
            'différentes
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

            'vérifier si la table est présente dans dbLink
            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) Then
                'tout est beau, on reconnecte
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect = ";Database=" & strDBPath
                    .RefreshLink
                    collTbls.Remove (.Name)
                End With
            Else
                Err.Raise cERR_NOREMOTETABLE
            End If
        End If
    Next
    fRefreshLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
    MsgBox "Toutes les tables Access furent reconnectées avec succès.", vbInformation +
vbOKOnly, "Succès"
fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3059:

        Case cERR_USERCANCEL:
            MsgBox "Aucune base de données n'est spécifiée, ne peut reconnecter les tables.", _
                    vbCritical + vbOKOnly, _
                    "Erreur en rafraîchissant les liens."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE:
            MsgBox "La table '" & strTbl & "' n'est pas trouvée dans la base de donées " & _
                    vbCrLf & dbLink.Name & ". On ne peut rafraîchir le lien", _
                    vbCritical + vbOKOnly, _
                    "Erreur en rafraîchissant les liens."
            Resume fRefreshLinks_End
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbOKOnly + vbCritical, "Error"
            Resume fRefreshLinks_End
    End Select
End Function

Function fIsRemoteTable(dbRemote As DATABASE, strTbl As String) As Boolean
Dim tdf As TableDef
    On Error Resume Next
    Set tdf = dbRemote.TableDefs(strTbl)
    fIsRemoteTable = (Err = 0)
    Set tdf = Nothing
End Function

Function fGetMDBName(strIn As String) As String
'Appelle le dialogue  GetOpenFileName
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "All Files (*.*)", _
                    "*.*")

    fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function

Function fGetLinkedTables() As Collection
'Retourne toutes les tables liées
    Dim collTables As New Collection
    Dim tdf As TableDef, db As DATABASE
    Set db = CurrentDb
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                If Left$(.Connect, 4) = "ODBC" Then
                '    collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
                'ODBC Reconnect handled separately
                Else
                    collTables.Add Item:=.Name & .Connect, KEY:=.Name
                End If
            End If
        End With
    Next
    Set fGetLinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Function fParsePath(strIn As String) As String
    If Left$(strIn, 4) <> "ODBC" Then
        fParsePath = Right(strIn, Len(strIn) _
                        - (InStr(1, strIn, "DATABASE=") + 8))
    Else
        fParsePath = strIn
    End If
End Function

Function fParseTable(strIn As String) As String
    fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Code End ***************