Results 1 to 14 of 14
  1. #1
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206

    Automatically Re-Link Broken Table Links


    I've tried many different relink functions and can't seem to get them to work. I like this function and it run like it should, but doesn't relink, at the end it has Relinking successfull, but not relinked, I can set links in Access ok. I'm using Access 365 with a accdb split DB with a password. I've added txt file, and Added "Microsoft Office 14.0 Object Library" in references. I have Public Function CheckConn(TableName As String) As Boolean, Public Sub CheckBackEnd(), Public Function RelinkDriver(beDataBase As String, BackEndType As String, Optional strSearchPath) As Boolean, Private Function RefreshLinks(strFileName As String) As Boolean, Public Function GetFileFolder(strType As String, strTitle As String) As String. Also watched the video many times.
    How can I debug this? Any help would be great!

    http://accessjitsu.com/2016/01/10/mi...n-table-links/

    Mad-Tom

  2. #2
    Micron is online now Virtually Inert Person
    Windows 10 Access 2016
    Join Date
    Jun 2014
    Location
    Ontario, Canada
    Posts
    12,737
    Rather link to something you're not actually using, post your code within code tags here (# on forum toolbar). No point in looking at what you've adopted but changed to suit your needs. Or if you only want info on how to debug, do things like mouse over your variables while you step through your code, or debug.print them to the immediate window before using (the line has to actually execute first) or use the locals window, or use the watch window, or...
    Last edited by Micron; 02-09-2021 at 02:24 PM. Reason: clarification
    The more we hear silence, the more we begin to think about our value in this universe.
    Paraphrase of Professor Brian Cox.

  3. #3
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    Listed is the code that I'm using.

    Code:
    '***************************************
    '  Returns True if table can be located
    '***************************************
    Public Function CheckConn(TableName As String) As Boolean
    On Error Resume Next
        Dim rs As DAO.Recordset
        
        ' Open linked table to see if connection information is correct.
        Set rs = CurrentDb.OpenRecordset(TableName)
        
        ' If there's no error, return True
        If Err.Number = 0 Then
            CheckConn = True
        Else
            CheckConn = False
        End If
        
        rs.Close
        Set rs = Nothing
        
    End Function
    Public Sub CheckBackEnd()
    On Error GoTo SubError
        Dim strMsg As String
        Dim ConfigFile As String
        Dim SearchPath As String
        Dim FileNum As Integer
        Dim FileLine As String
        Dim strLineArray As Variant
        Dim SetupType As String
        Dim FolderLoc As String
        
        strMsg = "The program attempted to relink the front end database to the back end " & _
                "database, but was unsuccessfull." & vbCrLf & vbCrLf & _
                "You will need to locate the backend database and try again.  If you found " & _
                "the backend database, but the relink was still unsuccessfull, notify the " & _
                "programmer."
                
        'If we can't find the table, then relink the backend
        If CheckConn("PartsStartup") = False Then
            ConfigFile = CurrentProject.path & "\" & "SplitConfig.txt"
            
            If (Dir(ConfigFile) <> "") Then ' if configfile exists
                'Read our config file
                FileNum = FreeFile
                'Open file for input
                Open ConfigFile For Input As #FileNum
                'Read first record only
                Line Input #FileNum, FileLine
                Close #FileNum
                
                If FileLine = "" Then
                    SetupType = ""
                    FolderLoc = ""
                Else
                    strLineArray = Split(FileLine, "|")
                    SetupType = strLineArray(0)
                    FolderLoc = strLineArray(1)
                End If
                
                Select Case SetupType
                    Case "same", ""
                        If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, CurrentProject.path) = False Then
                            MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                            GoTo SubExit
                        End If
                    Case "diff"
                        If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, FolderLoc) = False Then
                            MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                            GoTo SubExit
                        End If
                End Select
            Else 'cannot find config file - try to link in current path
                If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, CurrentProject.path) = False Then
                    MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                    GoTo SubExit
                End If
            End If
        End If
        'For a "real" database, no message on successful re-link
        MsgBox "Relinking successfull!", vbInformation + vbOKOnly, "Relinking successfull"
     
    SubExit:
    On Error Resume Next
        Exit Sub
     
    SubError:
    On Error Resume Next
        MsgBox "modRefreshLinks/CheckBackEnd error: " & vbCrLf & Err.Number & " = " & Err.Description
        Resume SubExit
     
    End Sub
    '**********************************************************
    'Drives the re-linking of linked tables
    'Input:    beDataBase = backend database file name
    '          strSearchPath = folder to look for BE in
    'Returns:  True if all tables linked sucessfully
    '**********************************************************
    Public Function RelinkDriver(beDataBase As String, BackEndType As String, Optional strSearchPath) As Boolean
    On Error GoTo SubError
        Dim strFileName As String
        Dim strFileFolder As String
        Dim ConfigFile As String
        Dim FileNum As Integer
        Dim FileLine As String
        Dim msgx As String
     
        'If we aren't given a path, use the database path
        If IsMissing(strSearchPath) Then
            strSearchPath = CurrentProject.path
        End If
        
        If (Dir(strSearchPath & "\" & beDataBase) <> "") Then
            'Backend database file is found
            strFileName = strSearchPath & "\" & beDataBase
        Else
            'If we can't find the backend db, display the Open dialog box
            strFileName = GetFileFolder("file", "Choose the Access database holding your tables (the backend)")
            If strFileName = "" Then
                msgx = "You cancelled the search for " & beDataBase & vbCrLf & _
                           " All linked table references will remain AS IS." & vbCrLf & _
                           " You will probably need to locate the database and try again."
                GoTo SubExit
            End If
        End If
        
        'Fix the links
        If RefreshLinks(strFileName) = True Then
            'Test folders and set BackEndType for config file
            strFileFolder = Left(strFileName, InStrRev(strFileName, "\") - 1)
            If strFileFolder = CurrentProject.path Then
                BackEndType = "same"
                strFileFolder = ""
            Else
                BackEndType = "diff"
            End If
            
            ConfigFile = CurrentProject.path & "\" & "SplitConfig.txt"
            'Open and update our ConfigFile
            FileNum = FreeFile
            Open ConfigFile For Output As #FileNum
            FileLine = BackEndType & "|" & strFileFolder
            Print #FileNum, FileLine
        
            RelinkDriver = True
        Else
            RelinkDriver = False
        End If
        
    SubExit:
        On Error Resume Next
        Close #FileNum
        Exit Function
        
    SubError:
        RelinkDriver = False
        MsgBox "modRefreshLinks/RelinkDriver error: " & vbCrLf & Err.Number & " = " & Err.Description
        GoTo SubExit
        
    End Function
    '**********************************************************
    'Refreshes connection string to linked tables
    'Input:    full path and file name to backend database
    'Returns:  True if all tables linked sucessfully
    '**********************************************************
    Private Function RefreshLinks(strFileName As String) As Boolean
    On Error GoTo SubError
        Dim tdf As DAO.TableDef
        Dim ConnectStr As String
        Dim i As Integer
        Dim j As Integer
        Dim DbPWD As String
     
        ' Loop through all tables in the database.
        For Each tdf In CurrentDb.TableDefs
            'If the table has a connection string, it's a linked table
            If Len(tdf.Connect) > 0 Then
                'extract the password from the old connection string
                i = InStr(tdf.Connect, "PWD=")
                j = InStr(i, tdf.Connect, ";")
                DbPWD = Mid(tdf.Connect, i + 4, j - i - 4)
                
                
                ConnectStr = "MS Access;PWD=" & DbPWD & ";DATABASE=" & strFileName
                If ConnectStr <> tdf.Connect Then
                    tdf.Connect = ConnectStr
                    Err = 0
                    On Error Resume Next
                    DoCmd.Echo True, "Linking to ... " & tdf.Name
                    tdf.RefreshLink         ' Relink the table.
                    If Err <> 0 Then
                        RefreshLinks = False
                        Exit Function
                    End If
                End If
            End If
        Next tdf
     
        RefreshLinks = True        ' Relinking complete.
        
    SubExit:
        On Error Resume Next
        Exit Function
        
    SubError:
        RefreshLinks = False
        MsgBox "modRefreshLinks/RefreshLinks error: " & vbCrLf & Err.Number & " = " & Err.Description
        GoTo SubExit
    End Function
    Public Function GetFileFolder(strType As String, strTitle As String) As String
        'Add "Microsoft Office 14.0 Object Library" in references
        Dim fDialog As Office.FileDialog
        Dim varFile As Variant
        Dim typeOfPicker As Integer
    '    Const msoFileDialogFilePicker = 3
    '    Const msoFileDialogFolderPicker = 4
        
        Select Case strType
            Case "folder"
                typeOfPicker = msoFileDialogFolderPicker
            Case "file"
                typeOfPicker = msoFileDialogFilePicker
        End Select
        
        'Get the folder to start in
        Set fDialog = Application.FileDialog(typeOfPicker)
        With fDialog
            .title = strTitle
            .AllowMultiSelect = False
            .InitialFileName = "C:\Users"
            
            If .Show = True Then
                If .SelectedItems.Count = 0 Then
                    'User clicked open but didn't select a file
                    GetFileFolder = ""
                End If
                
                For Each varFile In .SelectedItems
                    GetFileFolder = varFile
                Next
            Else
                GetFileFolder = ""
            End If
        End With
    End Function

  4. #4
    Gicu's Avatar
    Gicu is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jul 2015
    Location
    Kelowna, BC, Canada
    Posts
    4,101
    Can you please also show us the txt file SplitConfig.txt from the same folder as your front-end?
    Cheers,
    Vlad Cucinschi
    MS Access Developer
    http://forestbyte.com/

  5. #5
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    This is my txt file in the same folder as DB.
    Thanks​
    Attached Files Attached Files

  6. #6
    June7's Avatar
    June7 is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    May 2011
    Location
    The Great Land
    Posts
    52,815
    Have you attempted to debug?
    How to attach file: http://www.accessforums.net/showthread.php?t=70301 To provide db: copy, remove confidential data, run compact & repair, zip w/Windows Compression.

  7. #7
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    Yes! All seems to be good. File name and folder.

  8. #8
    davegri's Avatar
    davegri is online now Excess Access
    Windows 10 Access 2016
    Join Date
    May 2012
    Location
    Denver
    Posts
    3,388
    I got this to work for me after modifying the code that assumes a password is present. ( The InStr function will throw error if i = 0 )
    See the red in function RefreshLinks. Also found it odd that the function was Private and changed it to Public.

    Code:
    Option Compare Database
    Option Explicit
    
    
    '***************************************
    '  Returns True if table can be located
    '***************************************
    Public Function CheckConn(TableName As String) As Boolean
        On Error GoTo Error_Handler
        Dim rs As DAO.Recordset
        CheckConn = True
        ' Open linked table to see if connection information is correct.
        Set rs = CurrentDb.OpenRecordset(TableName)
        
    Error_Handler_Exit:
        On Error Resume Next
        rs.Close
        Set rs = Nothing
        Exit Function
    Error_Handler:
        Select Case Err
            Case 3024
                CheckConn = False
            Case Else
                MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure CheckConn" & "."
        End Select
        Resume Error_Handler_Exit
    End Function
    Public Sub CheckBackEnd()
    'On Error GoTo SubError
        Dim strMsg As String
        Dim ConfigFile As String
        Dim SearchPath As String
        Dim FileNum As Integer
        Dim FileLine As String
        Dim strLineArray As Variant
        Dim SetupType As String
        Dim FolderLoc As String
        
        strMsg = "The program attempted to relink the front end database to the back end " & _
                "database, but was unsuccessfull." & vbCrLf & vbCrLf & _
                "You will need to locate the backend database and try again.  If you found " & _
                "the backend database, but the relink was still unsuccessfull, notify the " & _
                "programmer."
                
        'If we can't find the table, then relink the backend
        
        If CheckConn("PartsStartup") = False Then
            ConfigFile = CurrentProject.Path & "\" & "SplitConfig.txt"
            
            If (Dir(ConfigFile) <> "") Then ' if configfile exists
                'Read our config file
                FileNum = FreeFile
                'Open file for input
                Open ConfigFile For Input As #FileNum
                'Read first record only
                Line Input #FileNum, FileLine
                Close #FileNum
                
                If FileLine = "" Then
                    SetupType = ""
                    FolderLoc = ""
                Else
                    strLineArray = Split(FileLine, "|")
                    SetupType = strLineArray(0)
                    FolderLoc = strLineArray(1)
                End If
                
                Select Case SetupType
                    Case "same", ""
                        If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, CurrentProject.Path) = False Then
                            MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                            GoTo SubExit
                        End If
                    Case "diff"
                        If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, FolderLoc) = False Then
                            MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                            GoTo SubExit
                        End If
                End Select
            Else 'cannot find config file - try to link in current path
                If RelinkDriver("SplitWithConnectionStrings_be.accdb", SetupType, CurrentProject.Path) = False Then
                    MsgBox strMsg, vbCritical + vbOKOnly, "Relinking unsuccessfull"
                    GoTo SubExit
                End If
            End If
        End If
        'For a "real" database, no message on successful re-link
        MsgBox "Relinking successfull!", vbInformation + vbOKOnly, "Relinking successfull"
     
    SubExit:
    On Error Resume Next
        Exit Sub
     
    SubError:
    On Error Resume Next
        MsgBox "modRefreshLinks/CheckBackEnd error: " & vbCrLf & Err.Number & " = " & Err.Description
        Resume SubExit
     
    End Sub
    '**********************************************************
    'Drives the re-linking of linked tables
    'Input:    beDataBase = backend database file name
    '          strSearchPath = folder to look for BE in
    'Returns:  True if all tables linked sucessfully
    '**********************************************************
    Public Function RelinkDriver(beDataBase As String, BackEndType As String, Optional strSearchPath) As Boolean
    On Error GoTo SubError
        Dim strFileName As String
        Dim strFileFolder As String
        Dim ConfigFile As String
        Dim FileNum As Integer
        Dim FileLine As String
        Dim msgx As String
     
        'If we aren't given a path, use the database path
        If IsMissing(strSearchPath) Then
            strSearchPath = CurrentProject.Path
        End If
        
        If (Dir(strSearchPath & "\" & beDataBase) <> "") Then
            'Backend database file is found
            strFileName = strSearchPath & "\" & beDataBase
        Else
            'If we can't find the backend db, display the Open dialog box
            strFileName = GetFileFolder("file", "Choose the Access database holding your tables (the backend)")
            If strFileName = "" Then
                msgx = "You cancelled the search for " & beDataBase & vbCrLf & _
                           " All linked table references will remain AS IS." & vbCrLf & _
                           " You will probably need to locate the database and try again."
                GoTo SubExit
            End If
        End If
        
        'Fix the links
        If RefreshLinks(strFileName) = True Then
            'Test folders and set BackEndType for config file
            strFileFolder = Left(strFileName, InStrRev(strFileName, "\") - 1)
            If strFileFolder = CurrentProject.Path Then
                BackEndType = "same"
                strFileFolder = ""
            Else
                BackEndType = "diff"
            End If
            
            ConfigFile = CurrentProject.Path & "\" & "SplitConfig.txt"
            'Open and update our ConfigFile
            FileNum = FreeFile
            Open ConfigFile For Output As #FileNum
            FileLine = BackEndType & "|" & strFileFolder
            Print #FileNum, FileLine
        
            RelinkDriver = True
        Else
            RelinkDriver = False
        End If
        
    SubExit:
        On Error Resume Next
        Close #FileNum
        Exit Function
        
    SubError:
        RelinkDriver = False
        MsgBox "modRefreshLinks/RelinkDriver error: " & vbCrLf & Err.Number & " = " & Err.Description
        GoTo SubExit
        
    End Function
    '**********************************************************
    'Refreshes connection string to linked tables
    'Input:    full path and file name to backend database
    'Returns:  True if all tables linked sucessfully
    '**********************************************************
    Public Function RefreshLinks(strFileName As String) As Boolean
    On Error GoTo SubError
        Dim tdf As DAO.TableDef
        Dim ConnectStr As String
        Dim i As Integer
        Dim j As Integer
        Dim DbPWD As String
     
        ' Loop through all tables in the database.
        For Each tdf In CurrentDb.TableDefs
            'If the table has a connection string, it's a linked table
            If Len(tdf.Connect) > 0 Then
                'extract the password from the old connection string if present
                i = InStr(tdf.Connect, "PWD=")
                If i <> 0 Then
                    j = InStr(i, tdf.Connect, ";")
                    DbPWD = Mid(tdf.Connect, i + 4, j - i - 4)
                End If
                
                ConnectStr = "MS Access;PWD=" & DbPWD & ";DATABASE=" & strFileName
                If ConnectStr <> tdf.Connect Then
                    tdf.Connect = ConnectStr
                    Err = 0
                    On Error Resume Next
                    DoCmd.Echo True, "Linking to ... " & tdf.Name
                    tdf.RefreshLink         ' Relink the table.
                    If Err <> 0 Then
                        RefreshLinks = False
                        Exit Function
                    End If
                End If
            End If
        Next tdf
     
        RefreshLinks = True        ' Relinking complete.
        
    SubExit:
        On Error Resume Next
        Exit Function
        
    SubError:
        RefreshLinks = False
        MsgBox "modRefreshLinks/RefreshLinks error: " & vbCrLf & Err.Number & " = " & Err.Description
        GoTo SubExit
    End Function
    Public Function GetFileFolder(strType As String, strTitle As String) As String
        'Add "Microsoft Office 14.0 Object Library" in references
        Dim fDialog As Office.FileDialog
        Dim varFile As Variant
        Dim typeOfPicker As Integer
    '    Const msoFileDialogFilePicker = 3
    '    Const msoFileDialogFolderPicker = 4
        
        Select Case strType
            Case "folder"
                typeOfPicker = msoFileDialogFolderPicker
            Case "file"
                typeOfPicker = msoFileDialogFilePicker
        End Select
        
        'Get the folder to start in
        Set fDialog = Application.FileDialog(typeOfPicker)
        With fDialog
            .Title = strTitle
            .AllowMultiSelect = False
            .InitialFileName = "C:\Users"
            
            If .Show = True Then
                If .SelectedItems.Count = 0 Then
                    'User clicked open but didn't select a file
                    GetFileFolder = ""
                End If
                
                For Each varFile In .SelectedItems
                    GetFileFolder = varFile
                Next
            Else
                GetFileFolder = ""
            End If
        End With
    End Function

  9. #9
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    I did notice the Private myself, will give it a try with changes.
    Thanks!

  10. #10
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    What is the way to test this? I've been going to external Data, Link Table Manger, and deleting link in the FE. I get error file not found after I do this?

  11. #11
    davegri's Avatar
    davegri is online now Excess Access
    Windows 10 Access 2016
    Join Date
    May 2012
    Location
    Denver
    Posts
    3,388
    Just move the BE to a different folder.
    If your FE is not showing any tables (because you deleted them - the links that is) You will have to re-establish the links via External Data from the Access Menu. After those links are established, don't delete any more tables.
    Now you can move the BE to a different folder to see if the code works. You can hover over a table name in the navigation pane to see where Access thinks it is located, linked or not.

    Click image for larger version. 

Name:	mTom1.png 
Views:	14 
Size:	46.8 KB 
ID:	44193

  12. #12
    Gicu's Avatar
    Gicu is offline VIP
    Windows 10 Access 2010 32bit
    Join Date
    Jul 2015
    Location
    Kelowna, BC, Canada
    Posts
    4,101
    Do not touch the links; you should move the back-end from the current location (that works with the FE) to a different folder. Once you do that your FE will complain it cannot find the file when you open it. Modify the text file and update the back end folder in there to point to where you move it. Once you run the code the front-end should be linked to the new back-end location.

    Cheers,
    Vlad
    Vlad Cucinschi
    MS Access Developer
    http://forestbyte.com/

  13. #13
    MadTom's Avatar
    MadTom is offline Competent Performer
    Windows 10 Access 2016
    Join Date
    Jun 2018
    Location
    CT and VT
    Posts
    206
    Ok I've been testing this the wrong way all this time. I should of followed all the instructions on the website. All works great now!
    Thanks you all.
    Mad-Tom

  14. #14
    davegri's Avatar
    davegri is online now Excess Access
    Windows 10 Access 2016
    Join Date
    May 2012
    Location
    Denver
    Posts
    3,388
    Good to hear. And just so you know, another Access problem will soon pop up at the most unexpected time!

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Links Broken Data Mismatch / Mispell Error
    By Kiran Prakash in forum Access
    Replies: 1
    Last Post: 06-02-2018, 03:04 AM
  2. Replies: 7
    Last Post: 04-16-2014, 07:07 AM
  3. Broken link missing reference
    By Cran29 in forum Access
    Replies: 1
    Last Post: 04-25-2013, 02:03 PM
  4. Replies: 3
    Last Post: 12-10-2010, 01:02 PM
  5. Replies: 6
    Last Post: 09-30-2010, 11:12 AM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums