home

Tables:Refresh Table Links Automatically

Friday, April 04, 2003 23:58:11

Also check out the SubSt Method
Related: Granting Permissions to Users to Change Table Path

Very common scenario: you have a "split" database--a database split into "front" and "back" ends--and you move this database around from one machine to another, or one location to another, and you have to refresh the table links. How do you do this more easily?

Method 1: Simpler Method, Requires Backend to Be in Same Path as Front End

The following code, when executed, will automatically refresh the table links for you. It has a few caveats:

Creating the Code

  1. Create a new module. Enter the following code:
    Function UpdateLinkedDatabase() As Boolean
    '---------------------------------
    'Updates the linked table links
    'ensures the PDMS data file used is in the same directory as the PDMS file
    '(runs from Autoexec macro) or from function called on hidden form
    '---------------------------------
    'Data table has to be in the same folder and be the same name except
    ' for ending in _be. This can be modified in the line with the comment
    ' Line specifying name conventions of backend
    'Modified by Glenn Austin on 26/11/99
    
    On Error GoTo UpdateLinkedDatabase_Error
    
    Dim dbs As Database
    Dim tdf As TableDef
    Dim strLink As String, strFileName As String, strCurrentLink As String
    Dim intFileLength As Integer
    
        'get required link details
        Set dbs = CurrentDb
        strFileName = dbs.Name
        intFileLength = Len(strFileName)
       ' Next line is for specifying name conventions of backend
        strFileName = Left(strFileName, intFileLength - 4) & "_be.mdb"  
        strLink = ";DATABASE=" & strFileName    'link required
    
         'get current link details. In quotes, enter the name of one of the tables which exists
        Set tdf = dbs.TableDefs("tblInvoices")
        strCurrentLink = tdf.Connect        'current link
    
        If strLink = strCurrentLink Then
            UpdateLinkedDatabase = False
            Exit Function
        End If
    
        'update links for linked tables
        For Each tdf In dbs.TableDefs
            If tdf.Name Like "tbl*" Then
                tdf.Connect = strLink
                tdf.RefreshLink
            End If
        Next tdf
        UpdateLinkedDatabase = True
        MsgBox "Linked tables have been updated"
    Exit Function
    
    UpdateLinkedDatabase_Error:
      MsgBox "An error has occurred while trying to update the linked tables." _
       & " Ensure the PDMS Data File is in the same folder as the PDMS file." _
         , vbOKOnly, "Check PDMS Data File"
    Exit Function
    
    End Function
    
    
  2. Save the module with a meaningful name such as basRefreshTableLinks
  3. Call the function in a hidden form, autoexec macro, or drop-down option; obviously, the syntax will be either =UpdateLinkedDatabase() or Call UpdateLinkedDatabase.

Derived from comp.databases.ms-access, April 30th 2001, thread "Linked Table Management".

Method 2: From MVPS.Org, Allows Backend to Exist in Location Besides Frontend Location

The other method, derived from MVPS.Org site, contains much longer code, but this code allows the backend to be located in a place besides where the front-end is located. Note: like the 1st method, certain permissions have to be granted to secured databases to allow regular users--not just the administrator--to perform this operation. You can go to Microsoft's Link about this, or I have a page of my own (derived from Microsoft's, actually) explaining how.

To create the function:

  1. Create a new module. Copy and paste the following code (derived from http://www.mvps.org/access/tables/tbl0009.htm) and http://www.mvps.org/access/api/api0001.htm):
    ' Function name for calling is fRefreshLinks()
    '***************** Code Start **************
    'This code was originally written by Ken Getz.
    'It is not to be altered or distributed,
    'except as part of an application.
    'You are free to use it in any application,
    'provided the copyright notice is left unchanged.
    '
    ' Code courtesy of:
    ' Microsoft Access 95 How-To
    ' Ken Getz and Paul Litwin
    ' Waite Group Press, 1996
    
    Type tagOPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        strFilter As String
        strCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        strFile As String
        nMaxFile As Long
        strFileTitle As String
        nMaxFileTitle As Long
        strInitialDir As String
        strTitle As String
        Flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        strDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
    End Type
    
    Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
    
    Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
    Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
    
    Global Const ahtOFN_READONLY = &H1
    Global Const ahtOFN_OVERWRITEPROMPT = &H2
    Global Const ahtOFN_HIDEREADONLY = &H4
    Global Const ahtOFN_NOCHANGEDIR = &H8
    Global Const ahtOFN_SHOWHELP = &H10
    ' You won't use these.
    'Global Const ahtOFN_ENABLEHOOK = &H20
    'Global Const ahtOFN_ENABLETEMPLATE = &H40
    'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
    Global Const ahtOFN_NOVALIDATE = &H100
    Global Const ahtOFN_ALLOWMULTISELECT = &H200
    Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
    Global Const ahtOFN_PATHMUSTEXIST = &H800
    Global Const ahtOFN_FILEMUSTEXIST = &H1000
    Global Const ahtOFN_CREATEPROMPT = &H2000
    Global Const ahtOFN_SHAREAWARE = &H4000
    Global Const ahtOFN_NOREADONLYRETURN = &H8000
    Global Const ahtOFN_NOTESTFILECREATE = &H10000
    Global Const ahtOFN_NONETWORKBUTTON = &H20000
    Global Const ahtOFN_NOLONGNAMES = &H40000
    ' New for Windows 95
    Global Const ahtOFN_EXPLORER = &H80000
    Global Const ahtOFN_NODEREFERENCELINKS = &H100000
    Global Const ahtOFN_LONGNAMES = &H200000
    
    Function TestIt()
        Dim strFilter As String
        Dim lngFlags As Long
        strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
                        "*.MDA;*.MDB")
        strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
        strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
        strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
        MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _
            Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
            DialogTitle:="Hello! Open Me!")
        ' Since you passed in a variable for lngFlags,
        ' the function places the output flags value in the variable.
        Debug.Print Hex(lngFlags)
    End Function
    
    Function GetOpenFile(Optional varDirectory As Variant, _
        Optional varTitleForDialog As Variant) As Variant
    ' Here's an example that gets an Access database name.
    Dim strFilter As String
    Dim lngFlags As Long
    Dim varFileName As Variant
    ' Specify that the chosen file must already exist,
    ' don't change directories when you're done
    ' Also, don't bother displaying
    ' the read-only box. It'll only confuse people.
        lngFlags = ahtOFN_FILEMUSTEXIST Or _
                    ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
        If IsMissing(varDirectory) Then
            varDirectory = ""
        End If
        If IsMissing(varTitleForDialog) Then
            varTitleForDialog = ""
        End If
    
        ' Define the filter string and allocate space in the "c"
        ' string Duplicate this line with changes as necessary for
        ' more file templates.
        strFilter = ahtAddFilterItem(strFilter, _
                    "Access (*.mdb)", "*.MDB;*.MDA")
        ' Now actually call to get the file name.
        varFileName = ahtCommonFileOpenSave( _
                        OpenFile:=True, _
                        InitialDir:=varDirectory, _
                        Filter:=strFilter, _
                        Flags:=lngFlags, _
                        DialogTitle:=varTitleForDialog)
        If Not IsNull(varFileName) Then
            varFileName = TrimNull(varFileName)
        End If
        GetOpenFile = varFileName
    End Function
    
    Function ahtCommonFileOpenSave( _
                Optional ByRef Flags As Variant, _
                Optional ByVal InitialDir As Variant, _
                Optional ByVal Filter As Variant, _
                Optional ByVal FilterIndex As Variant, _
                Optional ByVal DefaultExt As Variant, _
                Optional ByVal FileName As Variant, _
                Optional ByVal DialogTitle As Variant, _
                Optional ByVal hwnd As Variant, _
                Optional ByVal OpenFile As Variant) As Variant
    ' This is the entry point you'll use to call the common
    ' file open/save dialog. The parameters are listed
    ' below, and all are optional.
    '
    ' In:
    ' Flags: one or more of the ahtOFN_* constants, OR'd together.
    ' InitialDir: the directory in which to first look
    ' Filter: a set of file filters, set up by calling
    ' AddFilterItem. See examples.
    ' FilterIndex: 1-based integer indicating which filter
    ' set to use, by default (1 if unspecified)
    ' DefaultExt: Extension to use if the user doesn't enter one.
    ' Only useful on file saves.
    ' FileName: Default value for the file name text box.
    ' DialogTitle: Title for the dialog.
    ' hWnd: parent window handle
    ' OpenFile: Boolean(True=Open File/False=Save As)
    ' Out:
    ' Return Value: Either Null or the selected filename
    Dim OFN As tagOPENFILENAME
    Dim strFileName As String
    Dim strFileTitle As String
    Dim fResult As Boolean
        ' Give the dialog a caption title.
        If IsMissing(InitialDir) Then InitialDir = CurDir
        If IsMissing(Filter) Then Filter = ""
        If IsMissing(FilterIndex) Then FilterIndex = 1
        If IsMissing(Flags) Then Flags = 0&
        If IsMissing(DefaultExt) Then DefaultExt = ""
        If IsMissing(FileName) Then FileName = ""
        If IsMissing(DialogTitle) Then DialogTitle = ""
        If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
        If IsMissing(OpenFile) Then OpenFile = True
        ' Allocate string space for the returned strings.
        strFileName = Left(FileName & String(256, 0), 256)
        strFileTitle = String(256, 0)
        ' Set up the data structure before you call the function
        With OFN
            .lStructSize = Len(OFN)
            .hwndOwner = hwnd
            .strFilter = Filter
            .nFilterIndex = FilterIndex
            .strFile = strFileName
            .nMaxFile = Len(strFileName)
            .strFileTitle = strFileTitle
            .nMaxFileTitle = Len(strFileTitle)
            .strTitle = DialogTitle
            .Flags = Flags
            .strDefExt = DefaultExt
            .strInitialDir = InitialDir
            ' Didn't think most people would want to deal with
            ' these options.
            .hInstance = 0
            '.strCustomFilter = ""
            '.nMaxCustFilter = 0
            .lpfnHook = 0
            'New for NT 4.0
            .strCustomFilter = String(255, 0)
            .nMaxCustFilter = 255
        End With
        ' This will pass the desired data structure to the
        ' Windows API, which will in turn it uses to display
        ' the Open/Save As Dialog.
        If OpenFile Then
            fResult = aht_apiGetOpenFileName(OFN)
        Else
            fResult = aht_apiGetSaveFileName(OFN)
        End If
    
        ' The function call filled in the strFileTitle member
        ' of the structure. You'll have to write special code
        ' to retrieve that if you're interested.
        If fResult Then
            ' You might care to check the Flags member of the
            ' structure to get information about the chosen file.
            ' In this example, if you bothered to pass in a
            ' value for Flags, we'll fill it in with the outgoing
            ' Flags value.
            If Not IsMissing(Flags) Then Flags = OFN.Flags
            ahtCommonFileOpenSave = TrimNull(OFN.strFile)
        Else
            ahtCommonFileOpenSave = vbNullString
        End If
    End Function
    
    Function ahtAddFilterItem(strFilter As String, _
        strDescription As String, Optional varItem As Variant) As String
    ' Tack a new chunk onto the file filter.
    ' That is, take the old value, stick onto it the description,
    ' (like "Databases"), a null character, the skeleton
    ' (like "*.mdb;*.mda") and a final null character.
    
        If IsMissing(varItem) Then varItem = "*.*"
        ahtAddFilterItem = strFilter & _
                    strDescription & vbNullChar & _
                    varItem & vbNullChar
    End Function
    
    Private Function TrimNull(ByVal strItem As String) As String
    Dim intPos As Integer
        intPos = InStr(strItem, vbNullChar)
        If intPos > 0 Then
            TrimNull = Left(strItem, intPos - 1)
        Else
            TrimNull = strItem
        End If
    End Function
    '************** Code End *****************
    
    '***************** Code Start ***************
    ' This code was originally written by Dev Ashish.
    ' It is not to be altered or distributed,
    ' except as part of an application.
    ' You are free to use it in any application,
    ' provided the copyright notice is left unchanged.
    '
    ' Code Courtesy of
    ' Dev Ashish
    '
    Function fRefreshLinks() As Boolean
    Dim strMsg As String, collTbls As Collection
    Dim i As Integer, strDBPath As String, strTbl As String
    Dim dbCurr As Database, dbLink As Database
    Dim tdfLocal As TableDef
    Dim varRet As Variant
    Dim strNewPath As String
    
    Const cERR_USERCANCEL = vbObjectError + 1000
    Const cERR_NOREMOTETABLE = vbObjectError + 2000
    
        On Local Error GoTo fRefreshLinks_Err
    
        If MsgBox("Are you sure you want to reconnect all Access tables?", _
                vbQuestion + vbYesNo, "Please confirm...") = vbNo Then err.Raise cERR_USERCANCEL
    
        'First get all linked tables in a collection
        Set collTbls = fGetLinkedTables
    
        'now link all of them
        Set dbCurr = CurrentDb
    
        strMsg = "Do you wish to specify a different path for the Access Tables?"
        
        If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes Then
            strNewPath = fGetMDBName("Please select a new datasource")
        Else
            strNewPath = vbNullString
        End If
    
        For i = collTbls.Count To 1 Step -1
            strDBPath = fParsePath(collTbls(i))
            strTbl = fParseTable(collTbls(i))
            varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")
            If Left$(strDBPath, 4) = "ODBC" Then
                'ODBC Tables
    'ODBC Tables handled separately
    ' Set tdfLocal = dbCurr.TableDefs(strTbl)
    ' With tdfLocal
    '     .Connect = pcCONNECT
    '     .RefreshLink
    '     collTbls.Remove (strTbl)
    ' End With
            Else
                If strNewPath <> vbNullString Then
                    'Try this first
                    strDBPath = strNewPath
                Else
                    If Len(Dir(strDBPath)) = 0 Then
                        'File Doesn't Exist, call GetOpenFileName
                        strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
                        If strDBPath = vbNullString Then
                            'user pressed cancel
                            err.Raise cERR_USERCANCEL
                        End If
                    End If
                End If
    
                'backend database exists
                'putting it here since we could have
                'tables from multiple sources
                Set dbLink = DBEngine(0).OpenDatabase(strDBPath)
    
                'check to see if the table is present in dbLink
                strTbl = fParseTable(collTbls(i))
                If fIsRemoteTable(dbLink, strTbl) Then
                    'everything's ok, reconnect
                    Set tdfLocal = dbCurr.TableDefs(strTbl)
                    With tdfLocal
                        .Connect = ";Database=" & strDBPath
                        .RefreshLink
                        collTbls.Remove (.Name)
                    End With
                Else
                    err.Raise cERR_NOREMOTETABLE
                End If
            End If
        Next
        fRefreshLinks = True
        varRet = SysCmd(acSysCmdClearStatus)
        MsgBox "All Access tables were successfully reconnected.", _
                vbInformation + vbOKOnly, _
                "Success"
    
    fRefreshLinks_End:
        Set collTbls = Nothing
        Set tdfLocal = Nothing
        Set dbLink = Nothing
        Set dbCurr = Nothing
        Exit Function
    fRefreshLinks_Err:
        fRefreshLinks = False
        Select Case err
            Case 3059:
    
            Case cERR_USERCANCEL:
                MsgBox "No Database was specified, couldn't link tables.", _
                        vbCritical + vbOKOnly, _
                        "Error in refreshing links."
                Resume fRefreshLinks_End
            Case cERR_NOREMOTETABLE:
                MsgBox "Table '" & strTbl & "' was not found in the database" & _
                        vbCrLf & dbLink.Name & ". Couldn't refresh links", _
                        vbCritical + vbOKOnly, _
                        "Error in refreshing links."
                Resume fRefreshLinks_End
            Case Else:
                strMsg = "Error Information..." & vbCrLf & vbCrLf
                strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
                strMsg = strMsg & "Description: " & err.description & vbCrLf
                strMsg = strMsg & "Error #: " & Format$(err.Number) & vbCrLf
                MsgBox strMsg, vbOKOnly + vbCritical, "Error"
                Resume fRefreshLinks_End
        End Select
    End Function
    
    Function fIsRemoteTable(dbRemote As Database, strTbl As String) As Boolean
    Dim tdf As TableDef
        On Error Resume Next
        Set tdf = dbRemote.TableDefs(strTbl)
        fIsRemoteTable = (err = 0)
        Set tdf = Nothing
    End Function
    
    Function fGetMDBName(strIn As String) As String
    'Calls GetOpenFileName dialog
    Dim strFilter As String
    
        strFilter = ahtAddFilterItem(strFilter, _
                        "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", _
                        "*.mdb; *.mda; *.mde; *.mdw")
        strFilter = ahtAddFilterItem(strFilter, _
                        "All Files (*.*)", _
                        "*.*")
    
        fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                    OpenFile:=True, _
                                    DialogTitle:=strIn, _
                                    Flags:=ahtOFN_HIDEREADONLY)
    End Function
    
    Function fGetLinkedTables() As Collection
    'Returns all linked tables
        Dim collTables As New Collection
        Dim tdf As TableDef, db As Database
        Set db = CurrentDb
        db.TableDefs.Refresh
        For Each tdf In db.TableDefs
            With tdf
                If Len(.Connect) > 0 Then
                    If Left$(.Connect, 4) = "ODBC" Then
                    '    collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
                    'ODBC Reconnect handled separately
                    Else
                        collTables.Add Item:=.Name & .Connect, Key:=.Name
                    End If
                End If
            End With
        Next
        Set fGetLinkedTables = collTables
        Set collTables = Nothing
        Set tdf = Nothing
        Set db = Nothing
    End Function
    
    Function fParsePath(strIn As String) As String
        If Left$(strIn, 4) <> "ODBC" Then
            fParsePath = right(strIn, Len(strIn) _
                            - (InStr(1, strIn, "DATABASE=") + 8))
        Else
            fParsePath = strIn
        End If
    End Function
    
    Function fParseTable(strIn As String) As String
        fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
    End Function
    '***************** Code End ***************
    
  2. Save this module with a name like basRefreshTableLinks
  3. Compile and save all modules

To execute this function, obviously you would use the syntax Call fRefreshLinks or =fRefreshLinks()