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 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

VBA Macro to remove special characters from path and/or filename and/or VBA object name

Solution originally posted here:
http://stackoverflow.com/a/14157011/1540567 

This VBA function removes special characters from a string.  In my case I wanted a single function to return a valid path and/or filename and/or VBAProject name.  It works with both URL and UNC paths (and tries to clean up any paths with mixed slashes).

It's easy enough to tweak this for other purposes.  You can specify additional "forbidden" characters easily and add any extra boolean switches for your own specific needs, or you could just split into separate functions.

The function also checks the maximum string length and either crops or pops up a message box if a filename (not path) exceeds 128 characters -- very useful for SharePoint uploads -- or a VBA object name exceeds 35 characters.

Function fn_Clean_Special(str As String, CropLength As Boolean _
    , Optional VBObjectName As Boolean) As String
'v1.03 2013-01-04 15:54
'removes invalid special characters from path/file string
', True stops message box warnings and autocrops string
'     [, True] also removes spaces and hyphens and periods (VBA object)
'~ " # % & * : < > ? { | } ..   / \   -

Dim b As Integer, c As Integer, pp As String
Const tt As String = "fn_Clean_Special"
Dim sc(0 To 18) As String
sc(0) = "~"
sc(1) = Chr(34)  ' Chr(34) = " quotemark
sc(2) = "#"
sc(3) = "%"
sc(4) = "&"
sc(5) = "*"
sc(6) = ":"
sc(7) = "<"
sc(8) = ">"
sc(9) = "?"
sc(10) = "{"
sc(11) = "|"
sc(12) = "}"
sc(13) = ".."
'slashes for filenames and VB Object names
sc(14) = "/"
sc(15) = "\"
'hyphen & space & period for VB Object names
sc(16) = "-"
sc(17) = " "
sc(18) = "."

'remove special characters from all
For b = 0 To 13
    str = Replace(str, sc(b), vbNullString)
Next b

'check filename length (length AFTER the LAST slash max 128 chars)
b = InStr(1, str, sc(14))  'look for fwd slash
If b > 0 Then
    str = Replace(str, sc(15), sc(14))  'remove all back slashes
    Do Until b = 0  'until last slash found
        c = b       'c is position of last slash
        b = b + 1                   'next position
        b = InStr(b, str, sc(14))   'next position
    Loop
Else  'no fwd slashes
    b = InStr(1, str, sc(15))  'look for back slash
    If b > 0 Then
        str = Replace(str, sc(14), sc(15))  'remove all fwd slashes
        Do Until b = 0  'until last slash found
            c = b       'c is position of last slash
            b = b + 1                   'next position
            b = InStr(b, str, sc(15))   'next position
        Loop
    End If
End If
'c is position of last slash, or 0 if no slashes
If Len(str) - c > 128 Then
    If CropLength = True Then
        str = Left(str, 35)
    Else
        pp = "WARNING: filename > 128 chars"
        MsgBox pp, vbCritical, tt
    End If
End If

'remove slashes from filenames only
If c > 0 Then
    For b = 14 To 15
        str = Left(str, c) & Replace(Right(str, Len(str) - c), sc(b), vbNullString)
    Next b
End If


If VBObjectName = True Then
'remove slashes and swap hyphens & spaces & periods for underscore in VB object name
    Const scUS As String = "_"
    For b = 14 To 18
        str = Replace(str, sc(b), scUS)
    Next b
'then remove invalid characters from start of string
    Dim c1 As String
    c1 = Left(str, 1)
    Do While c1 = scUS Or c1 = sc(18) Or IsNumeric(c1)
        str = Right(str, Len(str) - 1)
        c1 = Left(str, 1)
    Loop
'remove double underscore
    Do While InStr(str, scUS & scUS) > 0
        str = Replace(str, scUS & scUS, scUS)
    Loop
    'check object name length (max 35 chars)
    If Len(str) > 35 Then
        If CropLength = True Then
            str = Left(str, 35)
        Else
            pp = "WARNING: object name > 35 chars"
            MsgBox pp, vbCritical, tt
        End If
    End If
End If

fn_Clean_Special = str

End Function

Debug Window results:

?fn_clean_special("\\server\path\filename.xls", True)
\\server\path\filename.xls
   
?fn_clean_special("\\server\path\filename.xls", True, True)
server_path_filename_xls

?fn_Clean_Special("\\special character\testing   for \VBproject.xls", True, True)
special_character_testing_for_VBpro