Relinking Tables etc

[Geoff Codd]

Hi there,

I am using the following code to check links on startup, the problem I am having is that it only sheck the links of Access tables and not xls or odbc tables, is there a way to modify the code to do this.

Thanks in advance
Geoff

Option Compare Database
Option Explicit
Global UnProcessed As New Collection

Public Function Browse()
' Prompts user for back-end database file name.
On Error GoTo Err_Browse
Dim strFilename As String
Dim oDialog As Object
Set oDialog = [Forms]![frmNew_Data_Location]!xDialog.Object
With oDialog ' Ask for new file location.
.DialogTitle = "Please Select New Data File"
.Filter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|" & _
"*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*"
.FilterIndex = 1
.ShowOpen
' If user responded, put selection into text box on form.
If Len(.FileName) > 0 Then _
[Forms]![frmNew_Data_Location]![txtFileName] = .FileName
End With

Exit_Browse:
Exit Function
Err_Browse:

MsgBox err.Description
Resume Exit_Browse

End Function


Public Function ProcessTables()

Dim strTest As String
On Error GoTo Err_BeginLink

' Test for existence of file name\directory selected in
' Common Dialog Control.
strTest = Dir([Forms]![frmNew_Data_Location]![txtFileName])

On Error GoTo Err_BeginLink
If Len(strTest) = 0 Then ' File not found.
MsgBox "File not found. Please try again.", vbExclamation, _
"Link to new data file"
Exit Function
End If

' Begin relinking tables.
Relinktables (strTest)
' Check to see if all tables have been relinked.
CheckifComplete

DoCmd.Echo True, "Done"
If UnProcessed.Count < 1 Then
MsgBox "Linking to new back-end data file was successful."
DoCmd.OpenForm "Switchboard", acNormal, , , acFormEdit, acWindowNormal
Else
MsgBox "Not All back-end tables were successfully relinked"
End If
DoCmd.Close acForm, [Forms]![frmNew_Data_Location].Name

Exit_BeginLink:
DoCmd.Echo True
Exit Function

Err_BeginLink:
Debug.Print err.Number
If err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox err.Description
Resume Exit_BeginLink

End Function

Public Sub ClearAll()
Dim x
' Clear any and all names from the Unprocessed Collection.
For Each x In UnProcessed
UnProcessed.Remove (x)
Next
End Sub

Public Function Relinktables(strFilename As String)

Dim dbbackend As Database, dblocal As Database, ws As Workspace, _
x, y
Dim tdlocal As TableDef

On Error GoTo Err_Relink

Set dbbackend = DBEngine(0).OpenDatabase(strFilename)
Set dblocal = CurrentDb

' If the local linked table name is found in the back-end database
' we're looking at, Recreate & Refresh its connect string, and
' then remove its name from the Unprocessed collection.
For Each x In UnProcessed
If Len(dblocal.TableDefs(x).Connect) > 0 Then
For Each y In dbbackend.TableDefs
If y.Name = x Then
Set tdlocal = dblocal.TableDefs(x)
tdlocal.Connect = ";DATABASE=" & _
Trim([Forms]![frmNew_Data_Location]![txtFileName])
tdlocal.RefreshLink
UnProcessed.Remove (x)
End If
Next
End If
Next

Exit_Relink:
Exit Function
Err_Relink:
MsgBox err.Description
Resume Exit_Relink

End Function

Public Sub CheckifComplete()

Dim strTest As String, y As String, notfound As String, x

On Error GoTo Err_BeginLink

' If there are any names left in the unprocessed collection,
' then continue.
If UnProcessed.Count > 0 Then
For Each x In UnProcessed
notfound = notfound & x & Chr(13)
Next
' List the tables that have not yet been relinked.
y = MsgBox("The following tables were not found in " & _
Chr(13) & Chr(13) & [Forms]![frmNew_Data_Location]!txtFileName _
& ":" & Chr(13) & Chr(13) & notfound & Chr(13) & _
"Select another database that contains the additional tables?", _
vbQuestion + vbYesNo, "Tables not found")

If y = vbNo Then
Exit Sub
End If

' Bring the Common Dialog Control back up.
Browse
strTest = Dir([Forms]![frmNew_Data_Location]![txtFileName])
If Len(strTest) = 0 Then ' File not found.
MsgBox "File not found. Please try again.", vbExclamation, _
"Link to new data file"
Exit Sub
End If
Debug.Print "Break"
Relinktables (strTest)
Else
Exit Sub
End If

CheckifComplete

Exit_BeginLink:
DoCmd.Echo True ' Just in case of error jump.
DoCmd.Hourglass False
Exit Sub

Err_BeginLink:
Debug.Print err.Number
If err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox err.Description
Resume Exit_BeginLink

End Sub

Public Function Check_Links()

' Check links to tables in Energy Reports database.
Dim strTest As String, db As Database
Dim td As TableDef
Dim txtMsg As String
Dim BadLinks As Boolean
Dim tblName As String
BadLinks = False
Set db = CurrentDb
ClearAll 'empty bad link collection
For Each td In db.TableDefs
If Len(td.Connect) > 0 Then ' Is a linked table.
On Error Resume Next ' Turn off error trap.
strTest = Dir(Mid(td.Connect, 11)) ' Check file name.
If Len(strTest) = 0 Then ' No matching file.
BadLinks = True
tblName = td.Connect
UnProcessed.Add Item:=td.Name, Key:=td.Name
Else
td.RefreshLink
End If
End If
Next ' Loop to next tabledef.
If BadLinks Then
txtMsg = "Couldn't find the back-end file " & Mid(tblName, 11) & ". Please choose new data file."
If MsgBox(txtMsg, vbExclamation + vbOKCancel + vbDefaultButton1, "Can't find backend data file.") = vbOK Then
DoCmd.OpenForm "frmNew_Data_Location", , , , , acWindowNormal, Mid(tblName, 11) ' Open prompt form.
Else
MsgBox "The linked tables can't find their source. " & _
"Please log onto network and restart the application."
DoCmd.Quit acQuitSaveNone
End If
End If

End Function