'   Перелинковка таблиц базы данных с выбором
Public Function RsRefreshTableLinksWhithChoice(sDirPath As String, Optional bIsAlwaysRelink = True) As Boolean
On Error Resume Next
    Dim str As String
On Error Resume Next
    Dim dbCur As DAO.Database
    Dim dbs As DAO.Database
    Dim td As DAO.TableDef
    Dim tdCur As DAO.TableDef
    Dim tds As DAO.TableDefs
    Dim tdsCur As DAO.TableDefs
    Dim sCnnStr As String
        
    RsRefreshTableLinksWhithChoice = False
    
    If Dir(sDirPath, vbDirectory) = "" Then
        Beep
        MsgBox "Указанный каталог " & sDirPath & " не существует", vbCritical, "Ошибка"
        Exit Function
    End If
    
    DoCmd.Hourglass True
    
    'коллеция табличек текущей базы данных
    Set dbCur = DBEngine.Workspaces( 0 ).Databases( 0 )
    Set tdsCur = dbCur.TableDefs

    '"MS Access;PWD=1;DATABASE=C:\ProServ\Data\psDocs.mdb"
    'коллекция линкуемых табличек
    'sCnnStr = "MS Access;PWD=1;DATABASE=" & Trim(sDirPath)
    Set dbs = DBEngine.Workspaces( 0 ).OpenDatabase(Trim(sDirPath)) ' куда сюда вкл. пароль на открытие файла БД(мдб)

    ' В хелпе написано , что вот так , но у меня не получилось
    'Set dbs = DBEngine.Workspaces(0).OpenDatabase(Trim(sDirPath),,"PWD=1")      
    Set tds = dbs.TableDefs

    'sCnnStr = "MS Access;PWD=1;DATABASE=" & Trim(sDirPath)
    sCnnStr = ";DATABASE=" & Trim(sDirPath)

    For Each td In tds 'коллекция линкованных таблиц
        If Mid(td.Name,  1 ,  4 ) <> "MSys" And Mid(td.Name,  1 ,  3 ) <> "tbl" Then
        'MsgBox "Refreshing table: " & td.Name
            PutStatus "Refreshing table: " & td.Name
            For Each tdCur In tdsCur
                If td.Name = tdCur.Name Then
                
                    If bIsAlwaysRelink = True Or dbCur.TableDefs(td.Name).Connect <> sCnnStr Then
                        dbCur.TableDefs(td.Name).Connect = sCnnStr
                        err =  0 
                        dbCur.TableDefs(td.Name).RefreshLink
                    End If
                Else
                
                End If
            Next tdCur
            
            If err <>  0  Then
               MsgBox "Error refreshing table " & td.Name, vbExclamation
            End If
            
        End If
    Next td
    
    Set dbs = Nothing
    Set td = Nothing
    Set tds = Nothing
    
    ClearStatus
    DoCmd.Hourglass False
    RsRefreshTableLinksWhithChoice = True
End Function