Kudos to a number of different people who've found similar solutions...
v1.00: acU_RelinkTables
Does a find & replace in linked tables. Cross-posted. Not sure why it took me so long to find the answer to this problem, but it did.... so after 5 years of manually updating linked tables I finally got the answer.
v1.01 improved messaging, case sensitivity bugfix
v2.00: acU_ChangeQueryPaths
Does a find & replace in SQL in all queries.
'accUtils
'v2.00 2014-01-16 13:46
'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
' Tom Parish
' TJP@tomparish.me.uk
' http://baldywrittencod.blogspot.com / www.baldmosher.com
' DGF Help Contact: see BPMHelpContact module
'=========================================================================
'===========================================================================
' accUtils
'===========================================================================
' Various time-saving utilities for Access databases
'
'===========================================================================
' Additional modules required:
'===========================================================================
' None
'
'=========================================================================
' VERSION HISTORY
'=========================================================================
'v2.00 2014-01-16 13:46 - added acU_ChangeQueryPaths (does a find & replace in all queries)
'v1.02 2013-12-05 14:18 - acU_RelinkTables, added Debug.Print for missing tables
'v1.01 2013-12-04 15:06 - acU_RelinkTables, bugfix for case sensitivity, added t count, improved msgboxes
'v1.00 2013-12-04 14:31 - added acU_RelinkTables (does a find & replace in linked tables)
Option Compare Database
Public Sub acU_RelinkTables(ByVal OldBasePath As String, ByVal NewBasePath As String _
, Optional ByVal AlsoChangeQueries As Boolean = True)
'v1.02 2013-12-05 14:18 - added Debug.Print for missing tables
'v1.01 2013-12-04 15:06 - bugfix for case sensitivity, added t count, improved msgboxes
'v1.00 2013-12-04 14:31 - original version
'pass old & new path to update all linked tables
'and it will go through all the tables in your database and link them to the new location
'Original source: Written by John Hawkins 20/9/99 www.fabalou.com
'via http://database.ittoolbox.com/groups/technical-functional/access-l/how-to-programme-the-linked-table-manager-using-vba-in-ms-access-5185870
'Syntax:
' acU_RelinkTables("\\OldShare\FolderName\", "\\NewShare\FolderName\)
Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Dim TdfCurrentPath As String
Dim t As Integer, u As Integer 'NB: practical limit of 65536 linked tables
Dim pp As String, tt As String 'for msgboxes
Set Dbs = CurrentDb
Set Tdfs = Dbs.TableDefs
Screen.MousePointer = 11 'shows as "working"
'Loop through the tables collection
For Each Tdf In Tdfs
If Tdf.SourceTableName <> "" Then 'If the table source is other than a base table
TdfCurrentPath = Tdf.Connect
If InStr(UCase(TdfCurrentPath), UCase(OldBasePath)) > 0 Then 'If the current path needs to be changed
t = t + 1 'count tables processed
On Error Resume Next
Tdf.RefreshLink 'Refresh the link
If Err = 3011 Then GoTo OriginalTdfError 'bypasses change if current linked table isn't found
Tdf.Connect = Replace(TdfCurrentPath, OldBasePath, NewBasePath) 'Set the new source
Tdf.RefreshLink 'Refresh the link
If Err = 3011 Then GoTo EscapeOnError 'likely means error in new path - could be critical
u = u + 1 'count tables updated
On Error GoTo 0
End If
End If
OriginalTdfError:
If Err = 3011 Then Debug.Print "Error 3011: " & Tdf.Name & vbLf & TdfCurrentPath
Next 'Goto next table
pp = u & " tables have been relinked from " & OldBasePath & " to " & NewBasePath
If t > u Then pp = pp & vbLf & vbLf & "(" & t - u & " were not updated successfully because the original table was missing)"
tt = "Tables Relinked"
Screen.MousePointer = 0
MsgBox pp, vbInformation, tt
Exit Sub
EscapeOnError:
pp = "Possible major error: please ensure OldBasePath and NewBasePath are correct - you will now be returned to Debug"
tt = "WARNING"
MsgBox pp, vbExclamation, tt
On Error GoTo 0
Tdf.Connect = TdfCurrentPath 'return to original
Tdf.RefreshLink 'Refresh the link - errors here means the table was missing before... this needs to be resolved
'NB: to continue from where you left off, drag arrow up to Next
End Sub
Public Sub acU_ChangeQueryPaths(ByVal OldBasePath As String, ByVal NewBasePath As String)
'v2.00 2014-01-16 13:46 - original version
'pass old & new path to update all queries
'Original source: acU_RelinkTables
'Syntax:
' acU_ChangeQueryPaths("\\OldShare\FolderName\", "\\NewShare\FolderName\)
Dim Dbs As Database
Dim Qdf As QueryDef
Dim Qdfs As QueryDefs
Dim QdfOldSQL As String, QdfNewSQL As String
Dim q As Integer 'NB: practical limit of 65536 queries
Dim pp As String, tt As String 'for msgboxes
If Right(OldBasePath, 1) = "\" And Right(NewBasePath, 1) = "\" Then
pp = "This will Find & Replace in all queries. There is no validation for this. Use with caution. To Undo, simply re-run to correct the error." _
& vbLf & vbLf & "find: " & OldBasePath & vbLf & "replace: " & NewBasePath
tt = "WARNING"
If MsgBox(pp, vbExclamation Or vbOKCancel, tt) = vbCancel Then Exit Sub
Else
pp = "Your old and new paths must end with ""\"". Otherwise, errors may occur. Will now Exit." _
& vbLf & vbLf & "find: " & OldBasePath & vbLf & "replace: " & NewBasePath
tt = "CRITICAL WARNING"
MsgBox pp, vbCritical, tt
Exit Sub
End If
Set Dbs = CurrentDb
Set Qdfs = Dbs.QueryDefs
Screen.MousePointer = 11 'shows as "working"
For Each Qdf In Qdfs
QdfOldSQL = Qdf.SQL
QdfNewSQL = Replace(QdfOldSQL, OldBasePath, NewBasePath)
If QdfOldSQL <> QdfNewSQL Then
q = q + 1
Qdf.SQL = QdfNewSQL
End If
Next 'Goto next query
pp = q & " queries have been updated from " & OldBasePath & " to " & NewBasePath
tt = "Queries Updated"
Screen.MousePointer = 0
MsgBox pp, vbInformation, tt
End Sub
