Dynamically relink Access tables - Split Database

Snowflake68

Snowflake68

Registered User.
Local time
Today, 02:43
Joined
May 28, 2014
Messages
464
NO HELP REQUIRED TODAY, IM JUST PROVIDING INFORMATION SO THAT OTHERS CAN USE.

I have a split database with the tables in an Access database (2013) as the backend and all the forms and queries in another for the front end.

The system will be distributed to various users on different setups for them to use independently. So in order to maintain the linked tables I have found some code on a Microsoft blog (by 'Courtney Owen') that dynamically relinks them as long as the backend is in the same directory as the front end application. This all works perfectly although it did take me a while to fix the errors as the code I found wasnt a perfect working solution for me.

Here is the function 'RefreshTableLinks' which is called from a splash screen on launch of the front end application.

Code: 
Public Function RefreshTableLinks() As String

On Error GoTo ErrHandle

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strCon As String
Dim strBackEnd As String
Dim strMsg As String
Dim intErrorCount As Integer

Set db = CurrentDb

'Loop through the TableDefs Collection.
For Each tdf In db.TableDefs

    'Verify the table is a linked table.
    If Left$(tdf.Connect, 10) = ";DATABASE=" Then
        'Get the existing Connection String.
        strCon = Nz(tdf.Connect, "")
        'Get the name of the back-end database using String Functions.
        strBackEnd = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "\") - 1)))
        'Verify we have a value for the back-end
            If Len(strBackEnd & "") > 0 Then
                'Set a reference to the TableDef Object.
                Set tdf = db.TableDefs(tdf.Name)
                'Build the new Connection Property Value.
                tdf.Connect = ";DATABASE=" & CurrentProject.Path & strBackEnd
                'Refresh the table link.
                tdf.RefreshLink
            Else
                'There was a problem getting the name of the back-end.
                'Add the information to the message to notify the user.
                intErrorCount = intErrorCount + 1
                strMsg = strMsg & "Error getting back-end database name." & vbNewLine
                strMsg = strMsg & "Table Name: " & tdf.Name & vbNewLine
                strMsg = strMsg & "Connect = " & strCon & vbNewLine
            End If
    End If

Next tdf
ExitHere:

On Error Resume Next
    If intErrorCount > 0 Then
        strMsg = "There were errors refreshing the table links: " _
        & vbNewLine & strMsg & "In Procedure RefreshTableLinks"
        RefreshTableLinks = strMsg
    End If
    
Set tdf = Nothing
Set db = Nothing

Exit Function

ErrHandle:
    intErrorCount = intErrorCount + 1
    strMsg = strMsg & "Error " & Err.Number & " " & Err.Description
    strMsg = strMsg & vbNewLine & "Table Name: " & tdf.Name & vbNewLine
    strMsg = strMsg & "Connect = " & strCon & vbNewLine
Resume ExitHere

End Function

I wanted to change the code so that the backend sits in a separate sub directory but I didnt know how to change the code in order to achieve this. But I have persevered without asking for help from all you helpful people on here and have managed to achieved it all on my own.

I just wanted to share my final code to give something back on here so that others could use it too.

Code: 
Public Function RefreshTableLinks() As String

On Error GoTo ErrHandle

Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim strCon As String
Dim strBackEnd As String
Dim strMsg As String
Dim intErrorCount As Integer

Set db = CurrentDb

'Loop through the TableDefs Collection.
For Each tdf In db.TableDefs

    'Verify the table is a linked table.
    If Left$(tdf.Connect, 10) = ";DATABASE=" Then
        'Get the existing Connection String.
        strCon = Nz(tdf.Connect, "")
        'Get the name of the back-end database using String Functions.
        strBackEnd = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "Data\") - 1))) ' amended this line to include the backend sub directory 'Data'
        'Verify we have a value for the back-end
            If Len(strBackEnd & "") > 0 Then
                'Set a reference to the TableDef Object.
                Set tdf = db.TableDefs(tdf.Name)
                'Build the new Connection Property Value.
                tdf.Connect = ";DATABASE=" & CurrentProject.Path & "\" & strBackEnd ' amended this line to include "\" &
                'Refresh the table link.
                tdf.RefreshLink
            Else
                'There was a problem getting the name of the back-end.
                'Add the information to the message to notify the user.
                intErrorCount = intErrorCount + 1
                strMsg = strMsg & "Error getting back-end database name." & vbNewLine
                strMsg = strMsg & "Table Name: " & tdf.Name & vbNewLine
                strMsg = strMsg & "Connect = " & strCon & vbNewLine
            End If
    End If

Next tdf
ExitHere:

On Error Resume Next
    If intErrorCount > 0 Then
        strMsg = "There were errors refreshing the table links: " _
        & vbNewLine & strMsg & "In Procedure RefreshTableLinks"
        RefreshTableLinks = strMsg
    End If
    
Set tdf = Nothing
Set db = Nothing

Exit Function

ErrHandle:
    intErrorCount = intErrorCount + 1
    strMsg = strMsg & "Error " & Err.Number & " " & Err.Description
    strMsg = strMsg & vbNewLine & "Table Name: " & tdf.Name & vbNewLine
    strMsg = strMsg & "Connect = " & strCon & vbNewLine
Resume ExitHere

End Function

This is the code on my Splash screen. It needs to call the function before opening any form that is bound to a linked table.

Code: 
Private Sub Form_Open(Cancel As Integer)
    
DoCmd.ShowToolbar "Ribbon", acToolbarNo
    
    DoCmd.Maximize
    
     RefreshTableLinks
    
    
    Dim strMsg As String

'Run the Procedure, getting any error messages.
strMsg = RefreshTableLinks()

'strMsg will be a zero-length string if there is no error message.
    If Len(strMsg & "") = 0 Then
        Debug.Print "All; Tables; were; successfully; relinked."
    Else
        'Notify the user of the errors.
        MsgBox strMsg, vbCritical
    End If

End Sub

I hope this helps others that want to split their databases and hold the backend database in a sub directory of the application, whilst dynamically relinking the tables.
 
dynamically relinks them as long as the backend is in the same directory as the front end application.
Click to expand...

Do you mean to say "works as long as the ORIGINAL FE and the current BE are in the same place"? Because if you had to have the BE and FE in the same folder, there is no point in splitting.
 
The_Doc_Man said:
Do you mean to say "works as long as the ORIGINAL FE and the current BE are in the same place"? Because if you had to have the BE and FE in the same folder, there is no point in splitting.
Click to expand...

It works if you want to split the db into a front and back end but yes you have to have the sub directory in the directory of the front end.

Its useful for my purposes so thought it was useful to share :)
 
You should be able to access a BE in a different directory by replacing CurrentProject.Path in the line below with the path to your other directory.

<code>
tdf.Connect = ";DATABASE=" & CurrentProject.Path & "" & strBackEnd
</code>

The string would look something like this: "C:\path\to\BE"
OR if the BE is on a network server: "\\filesrvr\path\to\BE"
 
The_Doc_Man said:
Do you mean to say "works as long as the ORIGINAL FE and the current BE are in the same place"? Because if you had to have the BE and FE in the same folder, there is no point in splitting.
Click to expand...

True as a general point ....but could be useful if the database is getting very large i.e. close to 2 GB
 
iberrym said:
You should be able to access a BE in a different directory by replacing CurrentProject.Path in the line below with the path to your other directory.

<code>
tdf.Connect = ";DATABASE=" & CurrentProject.Path & "" & strBackEnd
</code>

The string would look something like this: "C:\path\to\BE"
OR if the BE is on a network server: "\\filesrvr\path\to\BE"
Click to expand...

Hi iberrym

I see this is your first post so welcome to AWF
Perhaps you could also do a short introductory post to give us an idea of your background / experience (if you haven't yet done so)
 
So I was looking for the same solution and I loved the post by Snowflake68.... I built off of it so thanks and had to share.

I too have a system where I need to send the fe and be but I don't have a clue where these people will put it so I needed a solution to link to the be no matter where it was previously or where it is now or by what name it is called.
I only have one be so my code doesn't help too much for more than one buuuuut... I suppose you could use a collection if you needed to.

This uses 2 functions. The first one tests the tables just like the OP but on error 3024 (can't find file) it calls for the second function.

Code: 
Public Function RefreshTableLinks() As String

On Error GoTo ErrHandle

Set dB = CurrentDb

'Loop through the TableDefs Collection.
For Each Tdf In dB.TableDefs
          'Verify the table is a linked table.
          If Left$(Tdf.Connect, 10) = ";DATABASE=" Then
          'Get the existing Connection String.
          strCon = Nz(Tdf.Connect, "")
          'Get the name of the back-end database using String Functions.
          strBackEnd = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "\") - 1)))
          'get the back-end location if back-end was not stored in the same file as the front-end (includes BE file name
          strBackEndFolder = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "="))))
        
                    'Verify we have a value for the back-end
                    If Len(strBackEnd & "") > 0 Then
                    'Set a reference to the TableDef Object.
                              Set Tdf = dB.TableDefs(Tdf.Name)
                              'Build the new Connection Property Value.
                              Tdf.Connect = ";DATABASE=" & strBackEndFolder
                              'Refresh the table link.
                              Tdf.RefreshLink
                    'if the back-end file has moved the goto err3024 to start the RelinkNewTables function
                    Else
                              'There was a problem getting the name of the back-end.
                              'Add the information to the message to notify the user.
                              intErrorCount = intErrorCount + 1
                              strMsg = strMsg & "Error getting back-end database name." & vbNewLine
                              strMsg = strMsg & "Table Name: " & Tdf.Name & vbNewLine
                              strMsg = strMsg & "Connect = " & strCon & vbNewLine
                    End If
          End If
Next Tdf

GoTo ExitHere


Err3024:
'MsgBox "tables not link.  Re-link them now.", vbOKCancel
If MsgBox("tables not link.  Re-link them now.", vbOKCancel) = vbCancel Then
          GoTo ExitHere
End If

Call RelinkNewTables

ExitHere:

On Error Resume Next
    If intErrorCount > 0 Then
        strMsg = "There were errors refreshing the table links: " _
        & vbNewLine & strMsg & "In Procedure RefreshTableLinks"
        RefreshTableLinks = strMsg
    End If
    
Set Tdf = Nothing
Set dB = Nothing

Exit Function


ErrHandle:
If Err.Number = 3024 Then
          GoTo Err3024
End If

          intErrorCount = intErrorCount + 1
          strMsg = strMsg & "Error " & Err.Number & " " & Err.Description
          strMsg = strMsg & vbNewLine & "Table Name: " & Tdf.Name & vbNewLine
          strMsg = strMsg & "Connect = " & strCon & vbNewLine

Resume ExitHere

End Function
The second function uses a the file dialog box to find the new BE location and replaces the string values with the new file name and location
Code: 
Public Function RefreshTableLinks() As String

On Error GoTo ErrHandle

Set dB = CurrentDb

'Loop through the TableDefs Collection.
For Each Tdf In dB.TableDefs
          'Verify the table is a linked table.
          If Left$(Tdf.Connect, 10) = ";DATABASE=" Then
          'Get the existing Connection String.
          strCon = Nz(Tdf.Connect, "")
          'Get the name of the back-end database using String Functions.
          strBackEnd = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "\") - 1)))
          'get the back-end location if back-end was not stored in the same file as the front-end (includes BE file name
          strBackEndFolder = Right$(strCon, (Len(strCon) - (InStrRev(strCon, "="))))
        
                    'Verify we have a value for the back-end
                    If Len(strBackEnd & "") > 0 Then
                    'Set a reference to the TableDef Object.
                              Set Tdf = dB.TableDefs(Tdf.Name)
                              'Build the new Connection Property Value.
                              Tdf.Connect = ";DATABASE=" & strBackEndFolder
                              'Refresh the table link.
                              Tdf.RefreshLink
                    'if the back-end file has moved the goto err3024 to start the RelinkNewTables function
                    Else
                              'There was a problem getting the name of the back-end.
                              'Add the information to the message to notify the user.
                              intErrorCount = intErrorCount + 1
                              strMsg = strMsg & "Error getting back-end database name." & vbNewLine
                              strMsg = strMsg & "Table Name: " & Tdf.Name & vbNewLine
                              strMsg = strMsg & "Connect = " & strCon & vbNewLine
                    End If
          End If
Next Tdf

GoTo ExitHere


Err3024:
'MsgBox "tables not link.  Re-link them now.", vbOKCancel
If MsgBox("tables not link.  Re-link them now.", vbOKCancel) = vbCancel Then
          GoTo ExitHere
End If

Call RelinkNewTables

ExitHere:

On Error Resume Next
    If intErrorCount > 0 Then
        strMsg = "There were errors refreshing the table links: " _
        & vbNewLine & strMsg & "In Procedure RefreshTableLinks"
        RefreshTableLinks = strMsg
    End If
    
Set Tdf = Nothing
Set dB = Nothing

Exit Function


ErrHandle:
If Err.Number = 3024 Then
          GoTo Err3024
End If

          intErrorCount = intErrorCount + 1
          strMsg = strMsg & "Error " & Err.Number & " " & Err.Description
          strMsg = strMsg & vbNewLine & "Table Name: " & Tdf.Name & vbNewLine
          strMsg = strMsg & "Connect = " & strCon & vbNewLine

Resume ExitHere

End Function

I hope this thread continues to help! :)
 
You must log in or register to reply here.

Similar threads

essaytee
Why messagebox appears then closes on successful run of DoCmd.OutputTo....pdf
Replies
5
Views
243
Mark_
M
C
Sendkeys not working anymore
Replies
7
Views
1,686
NauticalGent
NauticalGent
N
Solved I want to be able to send a few emails in access 2016 using gmail but am having challenges
Replies
7
Views
413
nector
N
N
Solved How to send multiple attachment with CDO Gmail in MS Access VBA
Replies
11
Views
549
nector
N
N
Solved How to remove this error "the execution this software stopped due to run time" error in MS Access VBA
Replies
11
Views
663
Minty
Minty

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom