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