Option Compare Database
Option Explicit
Dim UnProcessed As New Collection
Public strPath As String
Public Function Relink_AutoExec()
' Tests a linked table for valid back-end.
On Error GoTo Err_Form_Open
Dim strTest As String, db As DAO.Database
Dim td As DAO.TableDef
Set db = CurrentDb
Dim lngRtn As Long
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.
On Error GoTo Err_Form_Open ' Turn on error trap.
If Len(strTest) = 0 Then ' No matching file.
lngRtn = MsgBox("Couldn't find the back-end file " & _
Mid(td.Connect, 11) & "." & vbCrLf & vbCrLf & "Please choose your database backend that has your data tables.", _
vbExclamation + vbOKCancel + vbDefaultButton1, _
"Can't find backend data file.")
If lngRtn = vbOK Then
strPath = GetFileDialog() ' Open prompt form.
If Len(strPath) > 0 Then ' user responded, put selection into text box on form.
'MsgBox strPath, vbInformation, "New Path"
Call ProcessTables
Else
MsgBox "No Back End Data Base Selected. Exiting Application", vbExclamation, "Must Select BE database."
DoCmd.Quit
End If
Exit Function ' to refresh links
Else
MsgBox "The linked tables can't find their source. " & _
"Please log onto network and restart the application."
Exit Function
End If
End If
End If
Next ' Loop to next tabledef.
Exit_Form_Open:
Exit Function
Err_Form_Open:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_Form_Open
End Function
Public Sub linkToBackend()
MsgBox "Pick the location of your backend database.", vbInformation, "Find Database"
strPath = GetFileDialog()
ReProcessTables
End Sub
Public Sub AppendTables()
On Error GoTo errlbl:
Dim db As DAO.Database, X As Variant
Dim strTest As String
' Add names of all table with invalid links to the Unprocessed Collection.
Set db = CurrentDb
ClearAll
For Each X In db.TableDefs
If Len(X.Connect) > 1 And Len(Dir(Mid(X.Connect, 11))) = 0 Then
' connect string exists, but file does not
UnProcessed.Add Item:=X.Name, Key:=X.Name
End If
Next
Exit Sub
errlbl:
If Err.Number = 52 Then
MsgBox "Network not present."
For Each X In db.TableDefs
If Len(X.Connect) > 1 Then
'MsgBox x.Name & " " & x.Connect
' connect string exists, but file does not
UnProcessed.Add Item:=X.Name, Key:=X.Name
End If
Next
Else
Call ErrHandler(Err.Number, Err.Description, "Error in Appendtables")
End If
End Sub
Public Function ProcessTables()
Dim strTest As String
On Error GoTo Err_BeginLink
' Call procedure to add all tables with broken links into a collection.
AppendTables
' Test for existence of file name\directory selected in Common Dialog Control.
MsgBox strPath
strTest = strPath
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."
Else
MsgBox "Not All back-end tables were successfully relinked."
End If
Exit_BeginLink:
DoCmd.Echo True
Exit Function
Err_BeginLink:
Debug.Print Err.Number
If Err.Number = 457 Then
ClearAll
Resume Next
ElseIf Err.Number = 3043 Then
MsgBox "Can not find the Master on the Network. Check that you have a good network connection."
Resume Exit_BeginLink
Else
Call ErrHandler(Err.Number, Err.Description, "Error in Processtables")
Resume Exit_BeginLink
End If
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 DAO.Database, dblocal As DAO.Database, ws As Workspace, X, Y
Dim tdlocal As DAO.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=" & strPath
tdlocal.RefreshLink
UnProcessed.Remove (X)
End If
Next
End If
Next
Exit_Relink:
Exit Function
Err_Relink:
If Err.Number = 3043 Then
MsgBox "Can not find the Master on the Network. Check that you have a good network connection."
Resume Exit_Relink
Else
Call ErrHandler(Err.Number, Err.Description, "Error in Relinktables")
Resume Exit_Relink
End If
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) & strPath _
& ":" & 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.
strPath = GetFileDialog
strTest = strPath
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.Number & ": " & Err.Description
Resume Exit_BeginLink
End Sub
Public Sub AppendAllTables()
Dim db As DAO.Database, X As Variant
Dim strTest As String
' Add names of all table with invalid links to the Unprocessed Collection.
Set db = CurrentDb
If Not UnProcessed Is Nothing Then
ClearAll
End If
For Each X In db.TableDefs
If Len(X.Connect) > 1 Then
' connect string exists, but file does not
UnProcessed.Add Item:=X.Name, Key:=X.Name
End If
Next
End Sub
Public Function ReProcessTables()
Dim strTest As String
On Error GoTo Err_BeginLink
' Call procedure to add all tables with broken links into a collection.
AppendAllTables
' Test for existence of file name\directory selected in Common Dialog Control.
strTest = strPath
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."
Else
MsgBox "Not All back-end tables were successfully relinked."
End If
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.Number & ": " & Err.Description
Resume Exit_BeginLink
End Function
