Option Compare Database
Option Explicit

'***************** Code Start ***************
'This code was originally written by Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Dev Ashish

Function fRefreshLinks(Путь As String) As Boolean
    Dim strMSG As String, collTbls As Collection
    Dim i As Integer, strDBPath As String, strTbl As String
    Dim dbCurr As Database, dbLink As Database
    Dim tdfLocal                   As TableDef
    Dim varRet                     As Variant
    Dim strNewPath                 As String
    Dim N                          As Long
    Const cERR_USERCANCEL = vbObjectError + 1000
    Const cERR_NOREMOTETABLE = vbObjectError + 2000
    Const cERR_NOREMOTETABLE_2 = vbObjectError + 91

    On Local Error GoTo fRefreshLinks_Err

    ' If MsgBox( "Вы действительно хотите переприсоединить таблицы?" , _
      vbQuestion + vbYesNo,  "Подтвердите..." ) = vbNo Then Err.Raise cERR_USERCANCEL

    'First get all linked tables in a collection
    Set collTbls = fGetLinkedTables

    'now link all of them
    Set dbCurr = CurrentDb


    strNewPath = Путь
    N = collTbls.Count
    For i = collTbls.Count To  1  Step - 1 
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus,  "Обрабатывается таблица '" & strTbl & "'...." )
        If Left$(strDBPath,  4 ) =  "ODBC"  Then
            'ODBC Tables
            'ODBC Tables handled separately
            ' Set tdfLocal = dbCurr.TableDefs(strTbl)
            ' With tdfLocal
            '     .Connect = pcCONNECT
            '     .RefreshLink
            '     collTbls.Remove (strTbl)
            ' End With
        Else
            If strNewPath <> vbNullString Then
                'Try this first
                strDBPath = strNewPath
            Else

            End If

            'backend database exists
            'putting it here since we could have
            'tables from multiple sources
            On Error GoTo fRefreshLinks_Err
            Set dbLink = DBEngine.Workspaces( 0 ).OpenDatabase(strDBPath)

            'check to see if the table is present in dbLink
            strTbl = fParseTable(collTbls(i))
            '            If fIsRemoteTable(dbLink, strTbl) Then
            If True Then
                'everything's ok, reconnect
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect =  ";Database="  & strDBPath
                    .RefreshLink
                    collTbls.Remove (.Name)    ' Удаление из меейстава Колекции
                End With
            Else
                err.Raise cERR_NOREMOTETABLE
            End If
        End If
    Next
    fRefreshLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
    MsgBox "Все таблицы успешно переприсоеденены. Обновлено " & N & " связей.", vbInformation + vbOKOnly, "Востановление прошло успешно..."


fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    If err.Number = 3078 Or err.Number = 3343 Or err.Number = cERR_NOREMOTETABLE_2 Then

        MsgBox "Выбранный файл " & dbLink.Name & " не является базой для хранения Ваших данных." & _
               "Найдите свой файл.", _
               vbCritical + vbOKOnly, _
               "Ошибка обновления присоединений."
        Resume fRefreshLinks_End
    End If
    Select Case err
        Case 3059:

        Case cERR_USERCANCEL
            MsgBox "Таблицы не были переприсоеденены.", _
                   vbCritical + vbOKOnly, _
                   "Ошибка обновления присоединений."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE
            MsgBox "Выбранный файл " & dbLink.Name & " не является базой для хранения Ваших данных." & _
                   "Найдите свой файл.", _
                   vbCritical + vbOKOnly, _
                   "Ошибка обновления присоединений."
            Resume fRefreshLinks_End
        Case Else:
            strMSG = "Возникла ошибка..." & vbCrLf & vbCrLf
            strMSG = strMSG & "Функции: fRefreshLinks" & vbCrLf
            strMSG = strMSG & "Описание: " & err.Description & vbCrLf
            strMSG = strMSG & "Номер №: " & Format$(err.Number) & vbCrLf
            MsgBox strMSG, vbOKOnly + vbCritical, "Error"
            Resume fRefreshLinks_End
    End Select
End Function

Function fIsRemoteTable(dbRemote As Database, strTbl As String) As Boolean
    Dim tdf                        As TableDef
    On Error Resume Next
    Set tdf = dbRemote.TableDefs(strTbl)
    fIsRemoteTable = (err = 0)

    Set tdf = Nothing
End Function



Function fGetLinkedTables() As Collection
'Returns all linked tables
    Dim collTables                 As New Collection
    Dim tdf As TableDef, db        As Database
    Set db = CurrentDb
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        With tdf
            If Len(.Connect) >  0  Then
                If Left$(.Connect,  4 ) =  "ODBC"  Then
                    collTables.Add item:=.Name &  ";"  & .Connect, Key:=.Name
                    'ODBC Reconnect handled separately
                Else
                    collTables.Add item:=.Name & .Connect, Key:=.Name
                End If
            End If
        End With
    Next
    Set fGetLinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Public Function fParsePath(strIN As String) As String
    If Left$(strIN, 4) <> "ODBC" Then
        fParsePath = Right(strIN, Len(strIN) _
                                  - (InStr(1, strIN, "DATABASE=") + 8))
    Else
        fParsePath = strIN
    End If
End Function

Function fParseTable(strIN As String) As String
    fParseTable = Left$(strIN, InStr(1, strIN, ";") - 1)
End Function
'***************** Code End ***************