MS-Access: Reattach tables

Reattach tables

Here is a little bit tricky one. Enjoy!

Public Function smsTrickyAutoRefreshLink() As Boolean
'*+
' 
ose     : Auto refresh links to the back-end mdb file(s)' tables which '   
' Pur
p         : is(are) located in the ***same*** directory as front-end one. ' 
 Front-end and back-end databases are located in the same '
' Assumptions : Back-end database(s) is/are MS Access one(s) '            
:            : directory. '             : Front-end database FileName is equal to its 
ase(s) name(s) is/are constant. ' ' Returns     : True
'             : Tools->Options->Advanced->Project Name. '             : Back-end data
b - Links were refreshed successfully. '             : False - Error detected during links auto refreshment. ' 
en     : 98/04/18 ' ' Tested on   : MS Access 97/WinNT 4.0 
' Author      : Shamil Salakhetdinov, St.Petersburg, Russia ' e-mail      : shamil@marta.darts.spb.ru ' ' Writ
t' ' Comments    : - The links are refreshed only if you move both front- and back-end '             :   to the new directory. 
directory and back-end into another '             :   links refreshment fails
'             : - If you copy/move front-end only the links aren't refreshed. '             : - If you move front-end into one
. '             : - etc... ' '-     On Error GoTo smsTrickyAutoRefreshLink_Err          Dim tdf As TableDef     Dim i As Integer     Dim strBackEndFileNameExt As String     Dim strTst As String 
       SysCmd acSysCmdSetSta
    Dim strConnect As String          DoCmd.Hourglass True     SysCmd acSysCmdSetStatus, "Starting links auto refreshment..."     ' look for linked table(s)     For Each tdf In CodeDb().TableDef
stus, "Processing table [" & tdf.Name & "]..."              If tdf.Connect <> "" Then         On Error Resume Next         ' check that link is actual         strTst = DBEngine(0).OpenDatabase(Mid(tdf.Connect, 11)).Name 
 & "]..."              
        If Err <> 0 Then           ' clear error and reset last On Error handler           On Error GoTo smsTrickyAutoRefreshLink_Err                      SysCmd acSysCmdSetStatus, "Refreshing link of table [" & tdf.Nam
e     ' get the Filename.Ext of backend mdb for current link           strBackEndFileNameExt = ""           For i = Len(tdf.Connect) To 1 Step -1             If Mid(tdf.Connect, i, 1) <> "\" Then 
string           strConnect = ";Database=" & _                       Mid(CodeDb().Na
              strBackEndFileNameExt = Mid(tdf.Connect, i, 1) & strBackEndFileNameExt             Else               Exit For             End If           Next                    ' get new connect
me, _                       1, InStr(1, CodeDb().Name, _                                   GetOption("Project Name")) - 1) & _                       strBackEndFileNameExt           If strConnect <> tdf.Connect Then              ' refresh link 
e(Mid(tdf.Connect, 11)).Name        
             tdf.Connect = strConnect              tdf.RefreshLink           Else              ' Force an error message to appear in the case if back-end is moved              ' to another directory              strTst = DBEngine(0).OpenDataba
s  End If         Else           On Error GoTo smsTrickyAutoRefreshLink_Err         End If       End If     Next          smsTrickyAutoRefreshLink = True      smsTrickyAutoRefreshLink_Exit:     SysCmd acSysCmdClearStatus     DoCmd.Hourglass False 
AutoRefreshLink = False     Resume
    smsTrickyAutoRefreshLink = True     Exit Function      smsTrickyAutoRefreshLink_Err:     MsgBox "smsTrickyAutoRefreshLink: " & Err & " - " & _            Err.Description, vbCritical + vbOKOnly, _            "Links Auto Refresher"     smsTrick
ysmsTrickyAutoRefreshLink_Exit 

End Function