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