---Soumis par 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 ***************