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