Wednesday, 4 December 2013

VBA Modules: Access: accUtils v2.00

Read this for full information on these modules

Kudos to a number of different people who've found similar solutions...

v1.00: acU_RelinkTables
Does a find & replace in linked tablesCross-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

No comments:

Post a comment