Automatically re-link tables 1

[mcelligott]

I am looking for a way to have the front-end of my database re-link to the back-end tables on the workstation only if the server is not available (ex: laptop). It should always look to the server first. Any ideas?

 

[votegop]

This will get you going...
This code checks the link on a linked table to see if it is valid. If it is not, it attempts to refresh all links using the path to the back-end you specify in code. It allows for an alternative search directory also. If it doesn't find it there, it prompts the user to find the back-end manually. You call it from "CheckMyDatabaseLinks()"

'This module re-links the front-end tables to the back-end tables;
'it will prompt you to specify a directory if it does not find
'the tables in the default or alternative directories.
Option Explicit
Option Compare Database

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
    "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
    "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean

Declare Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
                    ByVal lpWindowName As Long) As Long

Declare Function SendMessage Lib "user32" Alias _
    "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
                    ByVal wParam As Long, _
                    ByVal lParam As Long) As Long

Type MSA_OPENFILENAME
    strFilter As String
    lngFilterIndex As Long
    strInitialDir As String
    strInitialFile As String
    strDialogTitle As String
    strDefaultExtension As String
    lngFlags As Long
    strFullPathReturned As String
    strFileNameReturned As String
    intFileOffset As Integer
    intFileExtension As Integer
End Type

Const ALLFILES = "All Files"

Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As Long
    nMaxCustrFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustrData As Long
    lpfnHook As Long
    lpTemplateName As Long
End Type

Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10

Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer
    intNum = UBound(varFilt)
    If (intNum <> -1) Then
        For intRet = 0 To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod 2 = 0 Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If
    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer
    strFilter = ""
    intNum = 0
    intPos = 1
    intLastPos = 1
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum + 1
            intLastPos = intPos + 1
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos + 1
        End If
    Loop Until (intPos = 0)
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
        intNum = intNum + 1
    End If
    If intNum Mod 2 = 1 Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    MSA_ConvertFilterString = strFilter
End Function

Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
    Dim of As OPENFILENAME
    Dim intRet As Integer
    MSAOF_to_OF msaof, of
    of.flags = of.flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    MSA_SimpleGetSaveFileName = strRet
End Function

Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
    Dim of As OPENFILENAME
    Dim intRet As Integer
    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
    Dim strFile As String * 512
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance = 0
    of.lpstrCustomFilter = 0
    of.nMaxCustrFilter = 0
    of.lpfnHook = 0
    of.lpTemplateName = 0
    of.lCustrData = 0
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
    of.lpstrFile = msaof.strInitialFile _
        & String(512 - Len(msaof.strInitialFile), 0)
    of.nMaxFile = 511
    of.lpstrFileTitle = String(512, 0)
    of.nMaxFileTitle = 511
    of.lpstrTitle = msaof.strDialogTitle
    of.lpstrInitialDir = msaof.strInitialDir
    of.lpstrDefExt = msaof.strDefaultExtension
    of.flags = msaof.lngFlags
    of.lStructSize = Len(of)
End Sub

Public Function RelinkTables() As Boolean
On Error Resume Next
Const conNonExistentTable = 3011
Const conNotconEEC3Data = 3078
Const conEEC3DataNotFound = 3024
Const conAccessDenied = 3051
Const conReadOnlyDatabase = 3027
Const conNotValidPath = 3044
Const conDiskNetworkError = 3043
Const conAppTitle = "MYAPPTITLE"   'edit this to your app title
Dim strSearchPath As String
Dim strFileName As String
Dim strError As String
Dim strDatabase As String
Dim frm_ActiveForm As Form
Dim Msg As String
GetCustomization
Set frm_ActiveForm = Screen.ActiveForm
    strDatabase = "MyBackEnd.mdb"  'edit the name of the DB to link to
    strSearchPath = varMyDatabaseSearchPath   'edit this to your search path (pass in a variable or hard code in quotes)
    Err.Clear
Err_strSearchPath:
    If (Dir(strSearchPath & strDatabase) <> "") Then
        strFileName = strSearchPath & strDatabase
    Else
        Msg = "Couldn't find shared data for " & conAppTitle & " ."
        Msg = Msg & "You must locate " & strDatabase & "."
        Msg = Msg & " Are you connected to the Network?"
        MsgBox Msg, vbInformation, "Refresh Links"
        strFileName = FindSharedData(strSearchPath)
        If strFileName = "" Then
            strError = "Sorry, you must locate " & strDatabase & " to open " & conAppTitle & "."
            GoTo Exit_Failed
        End If
    End If
    frm_ActiveForm.Repaint
     If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
    If Err = conNotValidPath Or Err = conDiskNetworkError Or Err = conEEC3DataNotFound Then
        strSearchPath = "C:\MyDBdirectory\"    ' edit for what you want to be an alternative search direcory
        GoTo Err_strSearchPath
    End If
    Select Case Err
    Case conNonExistentTable, conNotconEEC3Data
        strError = "File '" & strFileName & "' does not contain the required " & strDatabase & " ."
    Case Err = conEEC3DataNotFound
        strError = "You can't run " & conAppTitle & " until you locate " & strDatabase & " ."
    Case Err = conAccessDenied
        strError = "Couldn't open " & strFileName & " because it is read-only or located on a read-only share."
    Case Err = conReadOnlyDatabase
        strError = "Can't reattach tables because " & conAppTitle & " is read-only or is located on a read-only share."
    Case Else
        strError = Err.Description
    End Select
Exit_Failed:
    MsgBox "Table Links Error", vbCritical, conAppTitle
    RelinkTables = False
End Function

Function FindSharedData(strSearchPath) As String
On Error Resume Next
Dim msaof As MSA_OPENFILENAME
    msaof.strDialogTitle = "Where is the file named DeveloTrackBE.mdb?"  'edit this to your Back End DB name
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Access Databases", "*.mdb;*.mde")
    MSA_GetOpenFileName msaof
    FindSharedData = Trim(msaof.strFullPathReturned)
End Function

Function MSA_SimpleGetOpenFileName() As String
On Error Resume Next
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    MSA_SimpleGetOpenFileName = strRet
End Function

Public Function CheckLinks() As Boolean
On Error Resume Next
Dim DBS As Database, rst As Recordset
Set DBS = CurrentDb()
Set rst = DBS.OpenRecordset("OneOfMyLinkedTables")  'type in a linked table name here
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
End Function

Private Sub OF_to_MSAOF1(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
On Error Resume Next
    msaof.strFullPathReturned = Left$(of.lpstrFile, InStr(of.lpstrFile, Chr$(0)))
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Function RefreshLinks(strFileName As String) As Boolean
On Error Resume Next
Dim DBS, dbsRefresh As Database
Dim intCount As Integer
Dim tdf As TableDef
    Set dbsRefresh = OpenDatabase(strFileName, False, False, "; pwd=") 'edit this if db is passworded (pwd=1234)
    Set DBS = CurrentDb()
    For intCount = 0 To DBS.TableDefs.Count - 1
        Set tdf = DBS.TableDefs(intCount)
        If Len(tdf.Connect) > 0 Then
            tdf.Connect = ";DATABASE=" & strFileName
            Err = 0
            On Error Resume Next
            tdf.RefreshLink
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next intCount
    dbsRefresh.Close
    'DoCmd.OpenForm "Login" 'edit this to your "Switchboard" or startup form; or leave it commented-out if you don't want to use it.
    DoCmd.Echo True, ""
    RefreshLinks = True
    
End Function

Public Function CheckMyDatabaseLinks()
On Error Resume Next
    If CheckLinks() = False Then
        If RelinkTables() = False Then
            'DoCmd.Quit acExit
        End If
    End If
End Function

Hope this helps. Credit goes elsewhere as this is not my code.

Jay

 

[formerTexan]

Hi,

Here's for starters. My routine checks each table individually in case there are multiple backends, but I think I have pulled out the pertinent parts for you to use.

Dim strServerPath as string 'path to server
Dim strNewPath as string 'workstation path
'The path isn't valid
If Len(Dir(strServerPath)) = 0 Then
'relink tables
Call pfRelink(strNewPath)
End If


Function pfReLink(strNewPath As String)
Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Set Dbs = CurrentDb
Set Tdf = Dbs.TableDefs

If Tdf.SourceTableName <> "" Then
'Set the new source
Tdf.Connect = ";DATABASE=" & strNewPath
Tdf.RefreshLink 'Refresh the link
End If
End Function

 

[mcelligott]

Thank you both for your responses. It is greatly appeciated. I must admit I am having a problem following some of the code. Questions for formerTexan:

1) Does this code get placed in the startup form?

2) I did not see where the strServerPath and strNewPath were set. I have added the paths that I would use. Are those the only changes I would need to make?

Dim strServerPath as string 'path to server
Dim strNewPath as string 'workstation path
Set strServerPath="\\oec911\operations database\ECD Operations Database_be.mdb"
Set strNewPath="c:\operations\ECD Operations Database_be.mdb"
'The path isn't valid
If Len(Dir(strServerPath)) = 0 Then
'relink tables
Call pfRelink(strNewPath)
End If


Function pfReLink(strNewPath As String)
Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Set Dbs = CurrentDb
Set Tdf = Dbs.TableDefs

If Tdf.SourceTableName <> "" Then
'Set the new source
Tdf.Connect = ";DATABASE=" & strNewPath
Tdf.RefreshLink 'Refresh the link
End If
End Function


Thanks,

Bob