Function RelinkTable(sBase, sTableArray) As Boolean
'false если были ошибка
'sBase = "c:\georgiy\tlfNew.mdb" ' путь к новому положению БД на диске
On Error GoTo RelinkTable_err

Dim j As Integer, oldConnectString
Dim dbs As Database
Dim tdf As TableDef
' Dim sBase As String
Dim lngX As Long

RelinkTable = False

Set dbs = CurrentDb
SysCmd acSysCmdInitMeter, "Открываю таблицы базы " & sBase, UBound(sTableArray) + 1
lngX = 0

For j = LBound(sTableArray) To UBound(sTableArray)

Set tdf = dbs.TableDefs(sTableArray(j))

If Len(tdf.Connect) > 0 Then
oldConnectString = tdf.Connect
tdf.Connect = ";DATABASE=" & sBase
tdf.RefreshLink
End If
lngX = lngX + 1
SysCmd acSysCmdUpdateMeter, lngX
Next

' MsgBox "Таблицы подлинкованы." & vbCr & sBase, vbOKOnly + vbInformation, "Минздрав доволен!"
RelinkTable = True

RelinkTable_exit:

dbs.Close
SysCmd acSysCmdUpdateMeter, UBound(sTableArray)
SysCmd acSysCmdClearStatus

Exit Function

RelinkTable_err:
Select Case Err.Number
Case 3011
'не найдена нужная таблица в указанном файле
MsgBox "В выбранном файле нет таблицы " & tdf.Name & vbCrLf & "Укажите правильный файл данных!" & vbCrLf & vbCrLf & "Смена подключения не произведена, источник данных прежний.", vbExclamation, "Ошибка"

'принудительное переключение обратно не нужно
'tdf.Connect = oldConnectString
'tdf.RefreshLink


Case Else
MsgBox "При переключении источника данных произошла ошибка:" & Err.Description
End Select
Resume RelinkTable_exit:

End Function