Линковка связных таблиц из разных баз данных…

Dim dbs As Database
Dim tdf As TableDef
Dim lngX As Long

Set dbs = CurrentDb
SysCmd acSysCmdInitMeter, "Открываю таблицы базы " & sBase, dbs.TableDefs.Count
lngX = 0
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & sBase – путь к таблице, формируется программно…
tdf.RefreshLink
End If
SysCmd acSysCmdUpdateMeter, lngX
Next tdf
MsgBox "Данные успешно подключены. Приятной работы!!!", vbOKOnly + vbInformation, "Подключение данных"
SysCmd acSysCmdUpdateMeter, dbs.TableDefs.Count
SysCmd (acSysCmdClearStatus)
dbs.Close

tdf = dbs.TableDefs("Phone")

For Each tdf In dbs.TableDefs
На 
For Each tdfMassiv In MassivTable

Option Compare Database
Option Explicit

' ===========================================================================
' Назначение модуля:
'           Настройка связанных таблиц на удаленные базы данных
' Автор:                            [скрыть]
' Организация:                      [скрыть]
' Дата начала разработки:           05.08.2002
' Дата последней модификации:       07.08.2002
' ===========================================================================

Private Type typFile
    FullPath    As String       ' Полный путь к файлу
    FileName    As String       ' Название файла
End Type

' ===========================================================================
' Назначение процедуры:
'           Настройка связанных таблиц на удаленные базы данных
' Автор:                            [скрыть]
' Создание:                         05.08.2002
' Последняя модификация:            07.08.2002
' ===========================================================================
Public Sub RequeryTable()
Dim rstPath         As ADODB.Recordset
Dim tdf             As DAO.TableDef
Dim strSQL          As String
Dim myFile(1 To 10) As typFile
Dim i               As Integer
Dim iCountPath      As Integer
Dim strConnect      As String

On Error GoTo ErrRequeryTable
    ' В этой таблице содержится информация о настройках приложения. 
    ' Там, где RefreshLink = True указываются пути к файлам баз данных
    ' необходимое условие - имена файлов должны быть разными
    strSQL = "SELECT * FROM STPath WHERE RefreshLink = True"
    Set rstPath = New ADODB.Recordset
    rstPath.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    i = 0
    ' Определение путей, которые нужно обновлять
    Do Until rstPath.EOF
        i = i + 1
        myFile(i).FullPath = rstPath.Fields("Path")
        myFile(i).FileName = GetShortFileName(myFile(i).FullPath)
        rstPath.MoveNext
    Loop
    rstPath.Close
    Set rstPath = Nothing
    iCountPath = i
    
    ' Проход по всем связанным таблицам и определение - нужно их обновлять или нет...
    'Set db = CurrentDb
    For Each tdf In CurrentDb.TableDefs
        ' Если это связанная таблица, то...
        strConnect = tdf.Connect
        If Len(tdf.Connect) > 0 Then
            ' Проверка, надо ли обновлять связи этой таблицы
            For i = 1 To iCountPath
                ' Если у этой таблицы подоходящая БД-источник, то...
                If UCase(GetShortFileName(strConnect)) = UCase(myFile(i).FileName) Then
                    ' Обновить связи для этой таблцы
                    tdf.Connect = ";DATABASE=" & myFile(i).FullPath
                    tdf.RefreshLink
                    Exit For
                End If
            Next
        Else
            debug.Print "Пропущена: " & tdf.Name
        End If
    Next
    
Exit1:
    ' Освобождение объектов
    Set tdf = Nothing
    
    Exit Sub

' Обработка ошибки подключения
ErrRequeryTable:
    
    MsgBox "Ошибка при обновлении связей таблиц:" & vbCrLf & Err.Description, _
            vbExclamation + vbOKOnly, "Обновление связей таблиц"
    GoTo Exit1
End Sub

' ===========================================================================
' Назначение процедуры:
'           Возвращает название файла из его полного пути
' Автор:                            [скрыть]
' Создание:                         05.08.2002
' Последняя модификация:            05.08.2002
' ===========================================================================
Public Function GetShortFileName(ByVal sFullPath As String) As String
Dim sReturn         As String
Dim i               As Integer
Dim strSimbol       As String

    sReturn = ""
    For i = Len(sFullPath) To 1 Step -1
        ' Поиск последнего слеша
        strSimbol = Trim(Mid(sFullPath, i, 1))
        If strSimbol = "/" Or strSimbol = "\" Then
            Exit For
        End If
        sReturn = strSimbol & sReturn
    Next
    GetShortFileName = sReturn
End Function