update linked table via VBA

Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
    Dim tbl As TableDef
    Dim x As Long, MaxX As Long
    Dim tblDB As String
    Me.Visible = False
    tblDB = myFolder & "Folder\Database.MDB"
    If Dir(tblDB) = "" Then
        MsgBox "No table database has been found, " & vbCr & vbCr & _
                "This application will not work, so its beeing closed", vbCritical
        Application.Quit
    End If
                       
    MaxX = 1 ' first count all attached tables
    For Each tbl In CurrentDb.TableDefs()
        If tbl.Attributes = dbAttachedTable Then MaxX = MaxX + 1
    Next tbl
    x = 1 ' Now update them
    For Each tbl In CurrentDb.TableDefs()
        If tbl.Attributes = dbAttachedTable Then
            tblDB = myFolder & Mid(tbl.Connect, InStr(1, tbl.Connect, "Folder\"))
            If tbl.Connect <> ";Database=" & tblDB Then
                Me.Visible = True
                Me.Repaint
                tbl.Connect = ";Database=" & tblDB
                tbl.RefreshLink
            End If
            x = x + 1
        End If
        Me.Fill.Width = x / MaxX * Me.FillTo.Width
    Next tbl
    If Me.Visible Then
        Me.lblWait.Caption = "Done relinking ... "
        Me.Repaint
        MaxX = Timer + 2
        Do While Timer <= MaxX
        Loop
    End If
    

    DoCmd.OpenForm "frmMain"
    DoCmd.Close acForm, Me.Name
    
End Sub
Function myFolder()
    myFolder = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
End Function

Dim CurDB As DAO.Database, tdfLinked As DAO.TableDef
    Dim TBDef As DAO.TableDef, InstallPath As String
    Dim DBPath As String
    Dim strBEPath As String

    strBEPath = DLookup("qryBELocation", "BEPath")
    DBPath = Application.CurrentProject.Path
    
    Set CurDB = CurrentDb
    For Each TBDef In CurDB.TableDefs
            If Len(TBDef.Connect) > 0 Then
            TBDef.Connect = ";DATABASE=" & DBPath & "strBEPath

            TBDef.RefreshLink
        End If
    Next TBDef

exit_RunFirstTime:
    Set CurDB = Nothing
    Set tdfLinked = Nothing
    Set TBDef = Nothing
    Exit Sub

err_RunFirstTime:
    MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbcrf, "An Error has occured in refresh tables"
    Resume exit_RunFirstTime

Public Sub acU_RelinkTables(ByVal OldBasePath As String, ByVal NewBasePath As String)
'v1.00 2013-12-04 14:13
'Tweaked by Tom Parish 2013-12-04 baldmosher.com
'pass old & new path to update all linked tables
'and it will go through all the tables in your database and link them to the new location
'Original source: Written by John Hawkins 20/9/99 fabalou.com
'via database.ittoolbox.com/groups/technical-functional/access-l/how-to-programme-the-linked-table-manager-using-vba-in-ms-access-5185870
'Syntax:
' acU_RelinkTables("c:\Users\Yourname\Databases\", "\\NewShare\Databases\)

Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Dim TdfCurrentPath As String
Dim u As Integer

Set Dbs = CurrentDb
Set Tdfs = Dbs.TableDefs

Screen.MousePointer = 11  'shows as "working"
'Loop through the tables collection
For Each Tdf In Tdfs
    If Tdf.SourceTableName <> "" Then 'If the table source is other than a base table
        TdfCurrentPath = Tdf.Connect
        If InStr(TdfCurrentPath, OldBasePath) > 0 Then  'If the current path needs to be changed
On Error Resume Next
            Tdf.RefreshLink 'Refresh the link
            If Err = 3011 Then GoTo OriginalTdfError    'bypasses change if current linked table isn't found
            Tdf.Connect = Replace(TdfCurrentPath, OldBasePath, NewBasePath)   'Set the new source
            Tdf.RefreshLink 'Refresh the link
            If Err = 3011 Then GoTo EscapeOnError    'likely means error in new path - could be critical
            u = u + 1
On Error GoTo 0
        End If
    End If
OriginalTdfError:
Next 'Goto next table

Screen.MousePointer = 0
MsgBox u & " tables have been relinked from " & OldBasePath & " to " & NewBasePath, vbInformation, "Tables Relinked"

Exit Sub
EscapeOnError:
MsgBox "Possible major error: please ensure OldBasePath and NewBasePath are correct - you will now be returned to Debug", vbExclamation, "WARNING"
On Error GoTo 0
Tdf.Connect = TdfCurrentPath 'return to original
Tdf.RefreshLink 'Refresh the link - errors here means the table was missing before... this needs to be resolved
'NB: to continue from where you left off, drag arrow up to Next
End Sub