Private Sub btnLinkData_Click()

    Dim cat As ADOX.Catalog, tbl As ADOX.Table, prop  As ADOX.Property
    Dim s As String, n As Integer, b As Boolean
    
    Set cat = New ADOX.Catalog
    Set cat.ActiveConnection = CurrentProject.Connection
    n =  0 : s = "": b = True
    For Each tbl In cat.Tables
        If Left(tbl.Name,  1 ) <> "~" And Left(tbl.Name,  4 ) <> "MSys" And _
            tbl.Properties("Jet OLEDB:Create Link") = True And _
            Len(tbl.Properties("Jet OLEDB:Link Datasource")) >  0  And _
            Len(tbl.Properties("Jet OLEDB:Remote Table Name")) >  0  _
        Then
On Error GoTo Err_Connect
            tbl.Properties("Jet OLEDB:Link Datasource") = Me.txtDataPath
            s = s & tbl.Name & "; "
            n = n +  1 
On Error GoTo  0 
Next_Table:
        End If
    Next tbl
    
    Me.btnClose.Enabled = b
    If b Then
        MsgBox _
            "Подключено " & CStr(n) & " таблиц из файла:" _
            & vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    Else
        MsgBox _
            "При подключении были ошибки. " & _
            Подключено " & CStr(n) & " таблиц " & _
            vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    End If
    Exit Sub
    
Err_Connect:
    b = False
    Dim s1 As String
    s1 = _
        "Ошибка подключения таблицы '" & tbl.Name & "'" & _
        vbNewLine & vbNewLine & _
        "Jet OLEDB:Link Datasource='" & tbl.Properties("Jet OLEDB:Link Datasource") & "'" & _
        vbNewLine & _
        "Jet OLEDB:Remote Table Name='" & tbl.Properties("Jet OLEDB:Remote Table Name") & "'" & _
        vbNewLine & vbNewLine & _
        "Код ошибки: " & CStr(Err.Number) & " Описание: " & Err.Description 
    If _
        MsgBox(s1 & vbNewLine & vbNewLine & _
        "Продолжить подключение ?", _
        vbCritical + vbYesNo) = vbYes _
    Then
        Resume Next_Table
    Else
        Exit Sub
    End If
End Sub