Option Compare Database
Option Explicit
Dim UnProcessed As New Collection
Public strPath As String
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.
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
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'************************************************************************ File Dialog *********************************************************************************
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Public Function GetFileDialog() As String
' Requires reference to Microsoft Office 11.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Allow user to make multiple selections in dialog box
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select Backend Database"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "Access Databases", "*.ACCDB"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
'Loop through each file selected and add it to our list box.
GetFileDialog = .SelectedItems(1)
' For Each varFile In .SelectedItems
' GetFileDialog = varFile
' Next
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
End Function
Public Function GetFolderDialog() As String
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
GetFolderDialog = sFolder
End Function