La préservation des tables liées pour l'accès BDs dans le même dossier lorsque les modifications de dossier
-
22-08-2019 - |
Question
J'ai deux bases de données Access qui partagent des tables liées. Ils sont déployés ensemble dans un répertoire et accessible via le code sous une forme Word.
Comment puis-je faire en sorte que les liens sont conservés lorsque les deux bases de données sont copiées (ensemble) dans un autre dossier? Depuis que je ne suis pas « ouvrir » la base de données, en tant que tel (il est en cours d'accès via ADO), je ne sais pas comment écrire du code pour actualiser les liens.
La solution
Mise à jour 14APR2009 J'ai trouvé que la réponse précédente, je lui ai donné ici était erronée, donc je mis à jour avec le nouveau code.
Comment procéder
- Copiez le code ci-dessous pour un module VBA.
-
A partir du code ou de la immédiate fenêtre dans le VBA IDE, il suffit de taper:
RefreshLinksToPath Application.CurrentProject.Path
maintenant réassocier toutes les tables liées à l'utilisation du répertoire où se trouve votre application.
Il ne doit être fait une fois ou chaque fois que vous rattachez ou ajouter de nouvelles tables.
Je recommande de faire ce à partir du code chaque fois que vous démarrez votre application.
Vous pouvez ensuite déplacer vos bases de données autour sans problème.
code
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
collTbls.Add Item:=.Name & .Connect, key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.count To 1 Step -1
strcon = collTbls(i)
' Get the original name of the linked table '
strDBPath = Right(strcon, Len(strcon) - (InStr(1, strcon, "DATABASE=") + 8))
' Get table name from connection string '
strTbl = Left$(strcon, InStr(1, strcon, ";") - 1)
' Get the name of the linked database '
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Reconstruct the full database path with the given path '
strDBPath = strNewPath & "\" & strDBName
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = ";Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
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
Resume fRefreshLinks_End
End Select
End Function
Ce code est une adaptation de cette source: http://www.mvps.org/ accès / tables / tbl0009.htm .
J'ai enlevé pour le rendre autonome toute dépendance à d'autres fonctions, c'est pourquoi il est un peu plus longtemps que prévu.
Autres conseils
Vous parlez de mettre à jour les liens dans votre formulaire Word ou les liens de table liés entre vos bases de données Access?
Pour les premiers, la meilleure façon que je sais est de garder votre chaîne de connexion (s) au niveau du module dans votre document Word / projet VBA et leur faire des chaînes const. Ensuite, lorsque le réglage de la chaîne de connexion pour vos objets de connexion ADO, passer la chaîne de connexion par rapport const.
Pour ce dernier, je serais tenté d'utiliser un chemin relatif dans la chaîne de connexion aux données dans chaque base de données d'accès à l'autre. Par exemple,
Dim connectionString as String
connectionString = ";DATABASE=" & CurrentProject.Path & "\[Database Name Here].mdb"
si comme vous le dites, les bases de données sont copiés ensemble dans un dossier différent (je suis en supposant dans le même dossier).
La réponse de Renaud ne fonctionne plus dans Access 2010 avec des fichiers Excel ou CSV.
Je l'ai fait quelques modifications:
- Adapté au modèle actuel de la chaîne de connexion
- Handled le chemin de la base de données différemment pour les fichiers Excel (y compris le nom de fichier) et les fichiers CSV (ne comprend pas le nom de fichier)
Voici le code:
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = _
TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
Debug.Print "Name: " & .Name
Debug.Print "Connect: " & .Connect
collTbls.Add Item:=.Name & ";" & .Connect, Key:=.Name
End If
End With
Next
Set tdf = Nothing
' Now link all of them'
For i = collTbls.Count To 1 Step -1
strConnRaw = collTbls(i)
' Get table name from the full connection string
strTbl = Left$(strConnRaw, InStr(1, strConnRaw, ";") - 1)
' Get original database path
strDBPath = Right(strConnRaw, Len(strConnRaw) - (InStr(1, strConnRaw, "DATABASE=") + 8))
' Get the name of the linked database
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
' Get remainder of connection string
strConn = Mid(strConnRaw, InStr(1, strConnRaw, ";") + 1, InStr(1, strConnRaw, "DATABASE=") _
- InStr(1, strConnRaw, ";") - 1)
' Reconstruct the full database path with the given path
' CSV-Files are not linked with their name!
If Left(strConn, 4) = "Text" Then
strDBPath = strNewPath
Else
strDBPath = strNewPath & "\" & strDBName
End If
' Reconnect '
Set tdf = dbCurr.TableDefs(strTbl)
With tdf
.Connect = strConn & "Database=" & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Next
RefreshLinksToPath = True
fRefreshLinks_End:
Set collTbls = Nothing
Set tdf = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_Err:
RefreshLinksToPath = False
Select Case Err
Case 3059:
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
Resume fRefreshLinks_End
End Select
End Function
Je suis malheureusement encore sur l'accès 2007. J'ai commencé avec l'un des blocs de code ci-dessus qui ne fonctionnait pas pour moi. Ayant moins accès puissance vba j'ai simplifié à seulement la première boucle qui obtient les chemins de table et il met à jour en place. Le gars à côté en cours d'exécution dans ce qui peut commenter ou mettre à jour.
Option Compare Database
'------------------------------------------------------------'
' Reconnect all linked tables using the given path. '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to '
' the moved tables again. '
' If the OnlyForTablesMatching parameter is given, then '
' each table name is tested against the LIKE operator for a '
' possible match to this parameter. '
' Only matching tables would be changed. '
' For instance: '
' RefreshLinksToPath(CurrentProject.Path, "local*") '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory. '
'
' Immediate window type
' RefreshLinksToPath Application.CurrentProject.Path
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean
Dim strDBPath As String
'Dim strTbl As String
'Dim strMsg As String
Dim strDBName As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef
Set dbCurr = CurrentDb
Dim strConn As String
Dim strNewDbConn1 As String
Dim strNewDbConn2 As String
Dim strNewDbConn As String
' On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
With tdf
If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
And (.Name Like OnlyForTablesMatching) Then
strConn = tdf.Connect
strDBPath = Right(strConn, Len(strConn) - (InStr(1, strConn, "DATABASE=") + 8))
strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
Debug.Print ("===========================")
Debug.Print (" connect is " + strConn)
Debug.Print (" DB PAth is " + strDBPath)
Debug.Print (" DB Name is " + strDBName)
strDBNewPath = strNewPath & "\" & strDBName
Debug.Print (" DB NewPath is " + strDBNewPath)
strNewDbConn1 = Left(strConn, (InStr(1, strConn, "DATABASE=") - 1))
strNewDbConn2 = "DATABASE=" & strDBNewPath
strNewDbConn = strNewDbConn1 & strNewDbConn2
Debug.Print (" DB strNewDbConn is " + strNewDbConn)
'Change the connect path
tdf.Connect = strNewDbConn
tdf.RefreshLink
End If
End With
Next
End Function