---Soumis par Timothy Pascoe et Lyle Fairfield---
Rétablir les liens de différentes sources de données.
en établissant de liens à diverses bases de données d'arrière-plan.
Il existe divers cas où plusieurs types différents de bases de données sont liés à une base de donnée Access en avant-plan, bases de données hétérogènes tel que ODBC, Excel, FoxPro, etc. Voici une procédure généralisée qui permet de rétablir le lien à toutes sources, indépendamment de leur type.
Vous pouvez utiliser cette procédure pendant que votre base de données est ouverte. Par exemple, ici, lors de l'exécution de la procédure événementielle de fermeture du formulaire de confirmation de démarrage (Splash form).
Private Sub Form_Close() If fRefreshLinks = False Then MsgBox "You have not refreshed the database links. This application " _ & "will can not function and will be terminated." DoCmd.Quit End If End SubNote: Ce code requiert la procédure GetOpenFileName fournie par Ken Getz. S'assurer de copier cette fonction depuis cet article.
This code goes in a new module.
'*********** Code Start ************ Const IntAttachedTableType As Integer = 6 Const ALLFILES = "All Files" Function fGetMDBName(strIn As String) As String 'Appeler 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 fRefreshLinks() As Boolean ' Code courtesy of: ' Microsoft Access 95 Solutions database ' Modified for Multiple Back-ends by Lyle Fairfield ' Updated to handle cancelation/incorrect selection by Timothy J. Pascoe ' Except where otherwise noted. Dim dbs As Database Dim rst As Recordset, rstTry As Recordset Dim tdf As TableDef Dim strOldConnect As String, strNewConnect As String Dim strFullLocation As String, strDatabase As String, strMsg As String Set dbs = CurrentDb() Set rst = dbs.OpenRecordset("SELECT MSysObjects.Connect, MsysObjects.Database, MSysObjects.Name from MSysObjects " & _ "WHERE MSysObjects.Type = " & IntAttachedTableType) If rst.RecordCount <> 0 Then rst.MoveFirst Do On Error Resume Next Set rstTry = dbs.OpenRecordset(rst![Name].Value) If Err = 0 Then rstTry.Close Set rstTry = Nothing Else On Error GoTo fRefreshLinks_Err strFullLocation = rst.Database strDatabase = FileName(strFullLocation) Set tdf = dbs.TableDefs(rst![Name].Value) strOldConnect = tdf.Connect strNewConnect = findConnect(strDatabase, tdf.Name, strOldConnect) 'If strNewConnect = "" Then 'Err.Raise 'Else For Each tdf In dbs.TableDefs If tdf.Connect = strOldConnect Then tdf.Connect = strNewConnect tdf.RefreshLink End If Next tdf dbs.TableDefs.Refresh 'End If End If Err = 0 rst.MoveNext If rst.EOF Then Exit Do End If Loop End If fRefreshLinks_End: Set tdf = Nothing Set rst = Nothing Set rstTry = Nothing fRefreshLinks = True Exit Function fRefreshLinks_Err: fRefreshLinks = False Select Case Err Case 3024: 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" End Select Exit Function End Function Function findConnect(strDatabase As String, strFileName As String, strConnect As String) As Variant Dim strSearchPath As String, strFileType As String, strFileSkelton As String Dim aExtension(6, 1) As String, i As Integer, _ strFindFullPath As String, strFindPath As String, strParameters As String strSearchPath = directoryFromConnect(strConnect) strFileType = "All Files" strFileSkelton = "*.*" aExtension(0, 0) = "dBase" aExtension(0, 1) = ".dbf" aExtension(1, 0) = "Paradox" aExtension(1, 1) = ".db" aExtension(2, 0) = "FoxPro" aExtension(2, 1) = ".dbf" aExtension(3, 0) = "Excel" aExtension(3, 1) = ".xls" aExtension(4, 0) = "Text" aExtension(4, 1) = ".txt" aExtension(5, 0) = "Exchange" aExtension(5, 1) = ".*" aExtension(6, 0) = "Access" aExtension(6, 1) = ".mdb" For i = 0 To 6 If InStr(strConnect, aExtension(i, 0)) <> 0 Then strFileName = strFileName & aExtension(i, 1) strFileSkelton = "*" & aExtension(i, 1) strFileType = aExtension(i, 0) Exit For End If Next i strFindFullPath = findFile(strDatabase, strSearchPath, strFileType, strFileSkelton) If strFindFullPath <> "" Then strFindPath = strPathfromFileName(strFindFullPath) strParameters = parametersFromConnect(strConnect) If InStr(strFindFullPath, "dbf") <> 0 Then findConnect = strParameters & strFindPath Else findConnect = strParameters & strFindFullPath End If End If End Function Function directoryFromConnect(strConnect As String) As String directoryFromConnect = Mid(strConnect, InStr(strConnect, "DATABASE=") + 9) End Function Function parametersFromConnect(strConnect As String) As String parametersFromConnect = left(strConnect, InStr(strConnect, "DATABASE=") + 8) End Function Function strPathfromFileName(strFileName As String) As String Dim i As Integer For i = Len(strFileName) To 1 Step -1 If Mid(strFileName, i, 1) = "\" Then Exit For End If Next i strPathfromFileName = left(strFileName, i - 1) End Function Function findFile(strDatabase, strSearchPath, strFileType, strFileSkelton) As String Dim strSelectedDatabase As String, strFullLocation As String, intlen As Integer, i As Integer Dim strIn As String Do strIn = "Where Is " & strDatabase & "?" findFile = Trim(fGetMDBName(strIn)) strSelectedDatabase = FileName(findFile) If strSelectedDatabase = "" Then Exit Do ElseIf strDatabase <> strSelectedDatabase Then MsgBox "You selected " & strSelectedDatabase & "@This is not the correct database.@Please select " & strDatabase & ".", vbInformation + vbOKOnly End If Loop Until strSelectedDatabase = strDatabase End Function Public Function FileName(strFullLocation As String) Dim intlen As Integer, i As Integer 'Get the Database Name, for use on the 'Find File' Form Caption intlen = Len(strFullLocation) For i = intlen To 1 Step -1 If Mid$(strFullLocation, i, 1) = "\" Then FileName = right$(strFullLocation, intlen - i) Exit For End If Next i End Function '*********** Code End ************