There reason you are getting 15 tables when you have only 8 is that
the system tables which are hidden are included in the count. You
don't want to use any table that starts with msys.
Here is a routine that will relink to a database you have selected. I
did not write it, and there are things about it I don't like, but it
does work. You will also need to copy the code at this site:
http://www.mvps.org/access/api/api0001.htm
It is used in this code.
Option Compare Database
Option Explicit
Dim UnProcessed As New Collection
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function BrowseNF()
Dim OFN As OPENFILENAME
Dim Ret
Dim GetFileFromAPI As String
With OFN
.lStructSize = Len(OFN)
.nMaxFile = 260 'The size given for the filepath and name i.e.
c:\prnin\outfile.txt at least 256
.lpstrTitle = "Please Select New Data File" 'Title of the Dialog Box
.lpstrInitialDir = "O:\Contract" 'Default Directory for the Dialog
box This can also be "\\server\dir"
'Filter the types of files for the Dialog box.
.lpstrFilter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|" &
"*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*"
.lpstrFile = String(.nMaxFile - 1, 0) 'get the buffer ready
Ret = GetOpenFileName(OFN) ' Call function.
GetFileFromAPI = Trim(Replace(.lpstrFile, vbNullChar, " "))
If Len(.lpstrFile) > 0 Then ' user responded, put selection
into text box on form.
[Forms]![frmNewDatafile]![txtFileName] = .lpstrFile
End If
End With
Exit_BrowseNF:
Exit Function
Err_BrowseNF:
MsgBox Err.Description
Resume Exit_BrowseNF
End Function
Public Sub AppendTables()
Dim db As DAO.Database, x As Variant
' 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 Then
' connect string exists, but file does not
UnProcessed.Add Item:=x.Name, Key:=x.Name
End If
Next
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 = Dir([Forms]![frmNewDatafile]![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."
Else
MsgBox "Not All back-end tables were successfully relinked."
End If
'Here is where you need to modify code to fit into your app.
' DoCmd.Close acForm, [Forms]![frmNewDatafile].Name
' DoCmd.OpenForm "Switchboard"
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
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, x, y
Dim tdlocal As DAO.TableDef
On Error GoTo Err_Relink
'You can modify this line if you don't have a database password
Set dbbackend = DBEngine(0).OpenDatabase(strFileName, False,
False, "MS Access;PWD=xxxx")
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]![frmNewDatafile]![txtFileName])
tdlocal.RefreshLink
UnProcessed.Remove (x)
End If
Next
End If
Next
Exit_Relink:
Exit Function
Err_Relink:
MsgBox Err.Number & ": " & 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]![frmNewDatafile]!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 Open File Dialog back up.
Browse
strTest = Dir([Forms]![frmNewDatafile]![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.Number & ": " & Err.Description
Resume Exit_BeginLink
End Sub
