Private Sub Form_Open(Cancel As Integer)
' Проверяем связи с таблицами в базе данных data.mdb.
    ' Проверяем доступность файла data.mdb.
    If CheckLinks() = False Then
        ' Пытаемся обновить связи; при неудаче закрываем форму.
        If RelinkTables() = False Then
            DoCmd.Close acForm, Me.Name
            CloseCurrentDatabase
        End If
    End If
End Sub

Public Function CheckLinks() As Boolean  
    Dim dbs As Database, rst As Recordset  
    Set dbs = CurrentDb
    On Error Resume Next
    Set rst = dbs.OpenRecordset( "Таблица" )

    ' Если нет ошибки, возвращает True.
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
    
End Function

Public Function RelinkTables() As Boolean
    Dim strSearchPath As String
    Dim strFileName As String
    Dim intError As Integer
    Dim strError As String
  
    Const conMaxTables = 8
    Const conNonExistentTable = 3011
    Const conNotDB = 3078
    Const conDBNotFound = 3024
    Const conAccessDenied = 3051
    Const conReadOnlyDatabase = 3027
    Const conAppTitle = "Примеры к уроку 11"

    ' Определяет имя каталога, в котором находится данный файл.
    strSearchPath = CurrentProject.Path &  "\" 

    ' Ищет базу данных 
    If (Dir(strSearchPath & "data.mdb") <> "") Then
        strFileName = strSearchPath & "data.mdb"
    Else
        ' Если база не найдена, выводится диалоговое окно  "Открытие" .
        MsgBox  "Не найдены связанные таблицы в базе данных 'data.mdb " & _
        "Необходимо найти 'data.mdb' для работы с приложением '"  & _
            conAppTitle &  "'.", vbExclamation
        strFileName = FindDB(strSearchPath)
        If strFileName = "" Then
            strError = "Необходимо найти 'data.mdb', чтобы открыть " & conAppTitle & "."
            GoTo Exit_Failed
        End If
    End If

    ' Фиксация связей.
    If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
    
    ' При неудаче выводит сообщение об ошибке.
    Select Case Err
    Case conNonExistentTable, conNotDB
        strError = "Файл '"  & strFileName &  "' не содержит нужных таблиц."
    Case Err = conDBNotFound
        strError = "Невозможно запустить " & conAppTitle & _
        " , пока не найдена база данных 'data.mdb'."
    Case Err = conAccessDenied
        strError = strError = "Невозможно открыть '"  & strFileName & _
         "'; файл доступен только для чтения."
    Case Err = conReadOnlyDatabase
        strError = "Невозможно восстановить связи таблиц. Приложение '"  & _
        conAppTitle & "' доступно только для чтения."
    Case Else
        strError = Err.Description
    End Select
    
Exit_Failed:
    MsgBox strError, vbCritical
    RelinkTables = False
End Function

Private Function RefreshLinks(strFileName As String) As Boolean
' Обновляет связи с указанной базой данных.
' При успешном выполнении возвращает True.

    Dim dbs As Database
    Dim tdf As TableDef

    ' Цикл по всем таблицам в базе данных.
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' Если таблица имеет строку подключения, она является связанной.
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' Обновляет связь.
            If Err <>  0  Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf

    RefreshLinks = True        ' Обновление связей завершено.
End Function