1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
| ' -------------------------------------------------------------------
Function VerifLien(strTable As String, strDBSce As String)
Dim db As DAO.Database, td As DAO.TableDef
Dim strConnect As String, strConnectNew As String
Dim strLinkedDB As String
On Error GoTo ErrH
Set db = CurrentDb
Set td = db.TableDefs(strTable)
If Not td Is Nothing Then
If (td.Attributes And dbAttachedTable) <> 0 Then
' Extraire Base Dorsale de la chaîne de connexion
strConnect = td.Connect
strLinkedDB = GetLinkedDB(strConnect)
' Si le chemin complet de la base dorsale est différent
' de celui attendu, recréer le lien.
If StrComp(strLinkedDB, strDBSce, vbTextCompare) <> 0 Then
' Créer nouvelle chaîne de connexion
strConnectNew = Replace(strConnect, strLinkedDB, strDBSce)
td.Connect = strConnectNew
' Recréer le lien
td.RefreshLink
End If
End If
End If
Sortie:
Exit Function
ErrH:
Select Case Err.Number
Case 3265 ' Elt non trouvé dans la collection
MsgBox "La table '" & strTable & "' n'exite pas.'"
Resume Sortie
End Select
MsgBox "Erreur No." & Err.Number & " : " & Err.Description
Resume Sortie
End Function
' -------------------------------------------------------------------
Function GetLinkedDB(strConnect As String) As String
Dim p As Long, strDBFullPathName As String
p = InStr(1, strConnect, "DATABASE=")
If p > 0 Then
strDBFullPathName = Mid(strConnect, p + Len("DATABASE="))
End If
p = InStr(1, strDBFullPathName, ";")
If p > 1 Then
strDBFullPathName = Left(strDBFullPathName, p - 1)
End If
GetLinkedDB = strDBFullPathName
End Function |
Partager