Linked tables in MS Access 2003

[Airtech]

I am building a media management tool and starting it in Access 2003.
I have various linked tables, and have sufficient code to loop through my list of linked tables to verify that the data file specified in the link is available in the specified path.

I am trying to finish this portion of my code to handle the table(s) whose links are broken because the specified file no longer exists.

Can someone suggest how I might "re-link" a table or several table (within the same data source) through VBA? Right now the links are to other MDB data sources.

What I am trying to avoid is running the re-link routine that I have every time the program starts even when there is nothing to do, and also I do not want to re-link tables whose links are perfectly good. Doing this, wastes a lot of startup time. I have about 11 tables now, but with the prospect if that list growing, I am trying to build my program to have a more intelligient way to check each link before "re-creating" it without having to redo all of them every time.

Thanks,
CJ

[Delerna]

Hard to see exactly what you are doing from the description, but one thought is to arrange things so that the relinking routine runs
only when you capture an error that occurs within some VBA code because of a broken link. Hope my meaning in that statement is clear?

Need more detail to give you an idea on how to go about doing that.

[Airtech]

OK, here is the code I have so far, this lists the tables that are linked into a collection each is referenced by an index, and the code which will extract the table name, and its current link from that indexed entry.
Then what I do is run a check to see if the referenced file exists.
This is where I start to run into trouble. If the file exists, then I would simply keep going through the collection until I came to a table which had a link to a different back-end database. Then I would test to see if that file existed and so on. If each of the different back-end files exist, then no re-linking should occur. This should allow, my program to start relatively quickly. If one or more of the back-end tables did not exist based on what the current link says it should be, then that table should be re-linked, test the next entry and so on.

Here is my code (kind of a collection of different things), there may be stuff in here, I really do not need once this is done.

Function DataSourceTest()
'This function is a test function built to test the back-end data connectivity code
'This will be the code that will list the tables, see where they are connected and whether or not the data source is actually available
 
Dim x
Dim TableDataPath As String
Dim PathToData As String
Dim NewFile As String
 
'Get list of linked tables, and their data source
fGetLinkedTables
 
'Loop through each item in the collection of linked tables to decide what to do with it
For x = 1 To LinkedTables.Count
    Debug.Print LinkedTables.Item(x)
 
    TableDataPath = Left$(LinkedTables.Item(x), InStrRev(LinkedTables.Item(x), ";"))
    TableDataPath = Left$(TableDataPath, Len(TableDataPath) - 1)
    Debug.Print TableDataPath
 
    PathToData = GetDataPath(TableDataPath)
    Debug.Print PathToData
 
    If FileOrDirExists(PathToData) = True Then
        'Available, do nothing
    Else
        'Not available, locate the data file
        MsgBox "The back-end data source for: " & TableDataPath & " is not available." & vbCrLf & "Please locate the data source."
        NewFile = fGetMDBName(TableDataPath)
    End If
Next
 
End Function
 
Function fGetLinkedTables()
'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 LinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function
 
Public Function GetDataPath(strTable As String) As String
'On Error GoTo Err_Handler
 
'Purpose:   Return the full path of the file from the Connect property of this tabledef.
'Return:    Full path and file name for attached MDB.
'           Just the path for some other types (e.g. attached text.)
'           Zero-length string for local table (not attached), or of argument is zero-length.
'           "#Error" on error, e.g. table not found.
'Requires:  Split() function for Access 97 or earlier.
 
Dim varArray As Variant
Dim i As Integer
 
If Trim$(strTable) <> vbNullString Then
    varArray = Split(CurrentDb.TableDefs(strTable).Connect, ";")
    For i = LBound(varArray) To UBound(varArray)
        If varArray(i) Like "DATABASE=*" Then
            GetDataPath = Trim$(Mid$(varArray(i), 10))
            Exit For
        End If
    Next
End If
 
Exit_Handler:
 
    Exit Function
 
Err_Handler:
 
    'Call LogError(Err.Number, Err.Description, conMod & ".GetDataPath", strTable, False)
    'GetDataPath = "#Error"
    Resume Exit_Handler
 
End Function
 
'This function will make sure the file specified in the linked property is available
'If available, then nothing should happen, if not, then a request to locate to data files will be presented to the user
 
Function FileOrDirExists(PathName As String) As Boolean
 
     'Macro Purpose: Function returns TRUE if the specified file
     '               or folder exists, false if not.
     'PathName     : Supports Windows mapped drives or UNC
     '             : Supports Macintosh paths
     'File usage   : Provide full file path and extension
     'Folder usage : Provide full folder path
     '               Accepts with/without trailing "\" (Windows)
     '               Accepts with/without trailing ":" (Macintosh)
 
    Dim iTemp As Integer
 
     'Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)
 
     'Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
 
     'Resume error checking
    On Error GoTo 0
 
End Function
 
Function fRefreshLinks() 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
 
Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000
 
    'On Local Error GoTo fRefreshLinks_Err
 
    'If MsgBox("Are you sure you want to reconnect all Access tables?", _
            vbQuestion + vbYesNo, "Please confirm...") = 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
 
    strMsg = "Do you wish to specify a different path for the Access Tables?"
 
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then
        strNewPath = fGetMDBName("Please select a new datasource")
    Else
        strNewPath = vbNullString
    End If
 
    For i = collTbls.Count To 1 Step -1
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & 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
                If Len(Dir(strDBPath)) = 0 Then
                    'File Doesn't Exist, call GetOpenFileName
                    strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                    If strDBPath = vbNullString Then
                        'user pressed cancel
                        Err.Raise cERR_USERCANCEL
                    End If
                End If
            End If
 
            'backend database exists
            'putting it here since we could have
            'tables from multiple sources
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath)
 
            'check to see if the table is present in dbLink
            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) 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 "All Access tables were successfully reconnected.", _
            vbInformation + vbOKOnly, _
            "Success"
 
fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3059:
 
        Case cERR_USERCANCEL:
            MsgBox "No Database was specified, couldn't link tables.", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE:
            MsgBox "Table '" & strTbl & "' was not found in the database" & _
                    vbCrLf & dbLink.Name & ". Couldn't refresh links", _
                    vbCritical + vbOKOnly, _
                    "Error in refreshing links."
            Resume fRefreshLinks_End
        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & 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 fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String
 
    strFilter = ahtAddFilterItem(strFilter, _
                    "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "All Files (*.*)", _
                    "*.*")
 
    fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function
 
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

Also, I do realize that the fRelinkTables function does actually to what my datsource test function is doing in part, but I am trying to get this down to just what I need.

Appreciate your help,and looking forward to your input.

Thanks,
CJ

[Airtech]

Also, this may not be quite as clean as it should or will be in the end, but the core functionality is what I am trying to do.

I suspect from your answer, you may have a better idea of how to handle this.

[NeoPa]

I'm working on something similar myself today, so I'll post something when I've worked it out if you like.

[NeoPa]

I found what I needed in other threads here, but I'll just link a couple of threads that got me going (Checking linked tables on startup & linked table).

The fundamental concept of relinking is to change the TableDef's .Connect string to reflect your new requirement, then call .RefreshLink for the TableDef.

The following code is a little routine I'm now using that returns the current address of the linked tables (Assumes all AccessLinked tables refer to the same database), and will optionally set them too, if a parameter is passed.

'LinkTo() Returns the name of the database that AccessLinked tables link to.
'Assumes all AccessLinked tables refer to the same database.
'Also allows caller to specify a location to change the links to (if necessary).
Public Function LinkTo(Optional ByVal strLinkDest As String = "") As String
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim intDB As Integer
    Dim strLink As String
    Dim varLinkAry As Variant
 
    Set db = CurrentDb
    For Each tdf In db.TableDefs
        With tdf
            If .Attributes And dbAttachedTable Then
                varLinkAry = Split(.Connect, ";")
                For intDB = LBound(varLinkAry) To UBound(varLinkAry)
                    If Left(varLinkAry(intDB), 9) = "DATABASE=" Then Exit For
                Next intDB
                strLink = Mid(varLinkAry(intDB), 10)
                If LinkTo = "" Then LinkTo = strLink
                If strLinkDest = "" Or strLinkDest = strLink Then Exit For
                varLinkAry(intDB) = "DATABASE=" & strLinkDest
                .Connect = Join(varLinkAry, ";")
                Call .RefreshLink
            End If
        End With
    Next tdf
End Function

[NeoPa]

As I found I needed to add some error handling code into this, for all but very well defined environments (IE All calls checked thoroughly beforehand for invalid links), I include the updated version. The extra length is due to the error handling code.

'LinkTo() Returns the name of the database that AccessLinked tables link to.
'Assumes all AccessLinked tables refer to the same database.
'Also allows caller to specify a location to change the links to (if necessary).
Public Function LinkTo(Optional ByVal strLinkDest As String = "") As String
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim intParam As Integer
    Dim strLink As String
    Dim varLinkAry As Variant
 
    Set db = CurrentDb
    For Each tdf In db.TableDefs
        With tdf
            If .Attributes And dbAttachedTable Then
                varLinkAry = Split(.Connect, ";")
                For intParam = LBound(varLinkAry) To UBound(varLinkAry)
                    If Left(varLinkAry(intParam), 9) = "DATABASE=" Then Exit For
                Next intParam
                strLink = Mid(varLinkAry(intParam), 10)
                If LinkTo = "" Then LinkTo = strLink
                If strLinkDest = "" Or strLinkDest = strLink Then Exit For
                varLinkAry(intParam) = "DATABASE=" & strLinkDest
                .Connect = Join(varLinkAry, ";")
                On Error Resume Next
                Call .RefreshLink
                Select Case Err.Number
                Case 3011, 3024, 3044, 3055, 7874
                    varLinkAry(intParam) = "DATABASE=" & strLink
                    .Connect = Join(varLinkAry, ";")
                    strLinkDest = "Database file (" & _
                                  strLinkDest & _
                                  ") not found"
                    Call MsgBox(strLinkDest, _
                                vbOKOnly Or vbExclamation, _
                                "LinkTo")
                    Exit For
                End Select
            End If
        End With
    Next tdf
End Function

[NeoPa]

By the way, while researching this I came across a very useful function AccessError(), which takes an error number and returns the associated text. It helped me select a buch of error codes that may cause this to fail due to files/objects not being where they should be. If anyone sees any others just flag them up & I'll update.