Проверка качества подключения таблиц

Private Function CheckConnectedTables() As Boolean

'es 18.01.04

'Проверка качества подключения всех подключенных таблиц

'Возвращает True если проверка прошла успешно

'===============================================================

Dim tbl As TableDef

Dim rst As Recordset

On Error GoTo CheckConnectedTablesErr

For Each tbl In CurrentDb.TableDefs

If tbl.Connect <> "" Then

Set rst = CurrentDb.OpenRecordset(tbl.Name, dbOpenDynaset)

End If

Next

CheckConnectedTables = True

CheckConnectedTablesBye:

On Error Resume Next

Set tbl = Nothing

rst.Close

Set rst = Nothing

Exit Function

CheckConnectedTablesErr:

'Сообщение не обязательно т.к. функция вернет - FALSE

'MsgBox "Функция [CheckConnectedTables] привела к ошибке:" & vbCrLf & _

'Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

Resume CheckConnectedTablesBye

End Function

Ещё вариант:

Function IsTableOK(sTableName As String) As Boolean

'es 19.12.2017

'ПРоверка качества соединени с одной табличкой

Dim objField As Field

On Error GoTo IsFieldPresentErr

Set objField = CurrentDb.TableDefs(sTableName).Fields(0)

IsTableOK = True 'Таблица в порядке!

Exit Function

IsFieldPresentErr:

Err.Clear

End Function

Примечание от Владимира Суханова:
      Проверку качества подключения можно осуществить и не открывая таблицы. Для этого достаточно (у связанных таблиц естественно) проверить значение свойства Tabledefs("Таблица").Fields.Count - если оно равно 0, значит таблица привязана не по тому адресу.
Т.е. функция будет уже такой:

Private Function CheckConnectedTables2() As Boolean

'Проверка качества подключения всех подключенных таблиц

'Возвращает True если проверка прошла успешно

'===============================================================

Dim tbl As TableDef

On Error GoTo CheckConnectedTablesErr

For Each tbl In CurrentDb.TableDefs

If tbl.Connect <> "" Then

If tbl.Fields.Count = 0 Then GoTo CheckConnectedTablesBye

End If

Next

'Проверка прошла

CheckConnectedTables2 = True

CheckConnectedTablesBye:

On Error Resume Next

Set tbl = Nothing

Exit Function

CheckConnectedTablesErr:

'Сообщение не обязательно т.к. функция вернет - FALSE

'MsgBox "Функция [CheckConnectedTables] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

Resume CheckConnectedTablesBye

End Function