Relink Access tables from code

In my Front end Access 2000 database, I have several linked tables from SQL Server database.  How can I make sure that all tables get connected when the front end is opened? That is I am looking for some code that will check that the tables are connected and then if not it will connect them for me (w/o prompting me to do it).

ps. I found this which is perfect except that it prompts the user to re-link the tables which I do not want to do.
Who is Participating?
Daniel StanleyDatabase engineerCommented:
try this out, i have a local table that houses the connect string that i want to use to link all of my database objects. from the form you select a dsn that you want to link to and then run the form.  i have included the code module that houses various function that are called during the relinking process by way of a attatchment form; i will inlcude the form code as well.  let me know if you'd like a copy of the form itself or if you need a full copy of the mdb to see it work properly; i find it works really well.  

good luck,

Option Compare Database
Option Explicit

Private Sub cmdCancel_Click()


End Sub

Private Sub cmdOK_Click()
    If IsNull(cboDataSource) Then
        MsgBox "Please select a data source.", vbInformation, "Incomplete Data"
        Call ap_RefreshAttachments(cboDataSource)
    End If

End Sub

Option Compare Database
Option Explicit

Option Base 1       'for using array in ap_CompareAscendConnect

'Note:  The declaration and usage of GetPrivateProfileString differs slightly from v2.0's 16-bit API call
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (
ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String,
ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

'Purpose:   Checks attachment of all ODBC-attached tables and SQL pass-through queries to ensure they match the
'             active connect string for the database
'Usage:     Call whenever database is opened (Autoexec macro)

Function ap_CompareAttachments()

    Dim db As Database, tdf As TableDef, qdf  As QueryDef
    Dim i As Integer
    Dim strCurrConnectFld As String
    Dim fMatchOk As Integer
    Dim strText As String
    Dim strTablesConnectRef As String
    Set db = CurrentDB()

    strCurrConnectFld = trim(Nz(DMin("[connectstr]", "connect_current"), Empty))

    If strCurrConnectFld = Empty Then
        MsgBox "Can't validate connections.  Please refresh attachments.", vbCritical, "Missing Current Connection"
        fMatchOk = True     'initialize return value for single elimination

        'Get the connection of an ODBC-attached table, to be used as the standard for comparison
        For Each tdf In db.TableDefs
            If tdf.Attributes And dbAttachedODBC Then
                strTablesConnectRef = tdf.Connect
                Exit For
            End If
        Next tdf
        'Check its host, service and database params against those of the active connect_string record
        fMatchOk = fMatchOk And (md_ParseConnectString(strCurrConnectFld, "HOST") = md_ParseConnectString(strTablesConnectRef, "HOST"))
        fMatchOk = fMatchOk And (md_ParseConnectString(strCurrConnectFld, "SERV") = md_ParseConnectString(strTablesConnectRef, "SERV"))
        fMatchOk = fMatchOk And (md_ParseConnectString(strCurrConnectFld, "DB") = md_ParseConnectString(strTablesConnectRef, "DB"))

        'Check each table's connection against the reference table's connection
        For Each tdf In db.TableDefs
            If tdf.Attributes And dbAttachedODBC Then      'ODBC-attached tables only
                fMatchOk = fMatchOk And (tdf.Connect = strTablesConnectRef)
            End If
        Next tdf
        'Check each pass-through query's connection against the recorded current connection.
        For Each qdf In db.QueryDefs
            If qdf.type = dbQSQLPassThrough Then      'SQL pass-through queries only
                fMatchOk = fMatchOk And (qdf.Connect = strCurrConnectFld)
            End If
        Next qdf
        If Not fMatchOk Then
            strText = "Some of the tables and queries in this reports database are not connected properly to the"
            strText = strText & " current data source.  Some reports may not function or may show incorrect"
            strText = strText & " data.  Please run the attachments utility to correct this."
            MsgBox strText, vbExclamation, "Inconsistent ODBC Connections"
        End If
    End If

End Function

Sub ap_RefreshAttachments(strDataSource)

    Dim db As Database, tdf As TableDef, qdf As QueryDef
    Dim strConnection As String
    Dim intI As Integer
    Dim varX As Variant
    Dim strSql As String
    'Variables added for Oracle
    Dim intPosn As Integer
    Dim fTargetOracle As Boolean
    Dim strTableName As String
    Dim strTmpNewTableObjName As String
    strConnection = trim(Nz(DLookup("[connectstr]", "connect_strings", "[server_name] = '" & strDataSource & "'"), Empty))
    If strConnection = Empty Then
        MsgBox "This server has no connection string - Try Again", vbExclamation, "Invalid Server Name"
        fTargetOracle = (InStr(1, strConnection, "SERV", vbTextCompare) = 0)    'Oracle connect strings do not have a SERVICE element
        Set db = CurrentDB()
        'Change connect strings for ODBC-attached tables.  (The For Each...Next construct is more modern and efficient, but
        'does not provide the counter needed for displaying a progress meter, thus the For...Next construct.)
        varX = SysCmd(acSysCmdInitMeter, "Reattaching Tables", db.TableDefs.Count)
        For intI = 0 To db.TableDefs.Count - 1
            Set tdf = db.TableDefs(intI)
            If tdf.Attributes And dbAttachedODBC Then
                'Added for issue 10471: In Access 2000, if user did not check "Save password" when first linking to a table, the setting
                'of the Connect property (below) no longer has the effect of setting the dbAttachSavePWD attribute to True.  The effect is that
                'the linked table's resulting Connect property is different from those tables where dbAttachSavePWD is True, and triggers
                'the "Inconsistent ODBC Connections" warning in ap_CompareAttachments.  The new code below explicitly checks for the condition
                'and fixes it.  The construct of the condition is necessary; checking for False is trickier than checking for True; it does not
                'work to check for "Not (tdf.Attributes And dbAttachSavePWD)".
                If (tdf.Attributes And dbAttachSavePWD) = 0 Then
                    tdf.Attributes = dbAttachSavePWD
                End If

                'tdf.Connect = strConnection
                ''On Error Resume Next      'already removed before Oracle conversion
                ''On Error GoTo 0           'already removed before Oracle conversion

                'Begin new code for Oracle
                intPosn = InStr(1, tdf.SourceTableName, ".", vbTextCompare)
                strTableName = LCase(trim(Right(tdf.SourceTableName, Len(tdf.SourceTableName) - intPosn)))
                strTmpNewTableObjName = "new_" & strTableName
                Set tdf = db.CreateTableDef(strTmpNewTableObjName)
                tdf.Connect = strConnection
                If fTargetOracle Then
                    tdf.SourceTableName = "ASCEND." & UCase(strTableName)
                    tdf.SourceTableName = strTableName
                End If
                db.TableDefs.Append tdf                                         'append the new tdf to the collection, under it's temporary name
                DoCmd.DeleteObject acTable, strTableName                        'if the append succeeds, delete the old tdf
                DoCmd.Rename strTableName, acTable, strTmpNewTableObjName       'rename the new tdf object to its regular table name
                'End new code for Oracle
                varX = SysCmd(acSysCmdUpdateMeter, intI)
            End If
        Next intI
        varX = SysCmd(acSysCmdRemoveMeter)
        'Change connect strings for queries that have them (pass-throughs)
        varX = SysCmd(acSysCmdInitMeter, "Reattaching Pass-Through Queries", db.QueryDefs.Count)
        For intI = 0 To db.QueryDefs.Count - 1
            Set qdf = db.QueryDefs(intI)
            If qdf.type = dbQSQLPassThrough Then
                qdf.Connect = strConnection
                varX = SysCmd(acSysCmdUpdateMeter, intI)
            End If
            qdf.ODBCTimeout = 60    'set ODBC timeout for all querys to 60 seconds
        Next intI
        varX = SysCmd(acSysCmdRemoveMeter)
        'Record the "current" connect string
        DoCmd.SetWarnings False
        DoCmd.RunSQL "DELETE connect_current.* FROM connect_current;"
        strSql = "          INSERT INTO connect_current ( server_name, connectstr )"
        strSql = strSql & "      SELECT connect_strings.server_name, connect_strings.connectstr"
        strSql = strSql & "        FROM connect_strings"
        strSql = strSql & "       WHERE connect_strings.server_name = '" & trim(strDataSource) & "';"
        DoCmd.RunSQL strSql
        DoCmd.SetWarnings True
    End If

End Sub

Private Function md_ParseConnectString(ByVal strConnect As String, ByVal strParamName As String) As String

    Dim intStartPosn As Integer
    Dim intEndPosn As Integer
    intStartPosn = InStr(strConnect, strParamName & "=") + Len(strParamName) + 1
    intEndPosn = InStr(intStartPosn, strConnect, ";") - 1
    md_ParseConnectString = trim(Mid(strConnect, intStartPosn, intEndPosn - intStartPosn + 1))

End Function

if it works perfect, just comment out the line that says:

If MsgBox("Are you sure you want to reconnect all Access tables?", _
            vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise

or delete it entirely... then the user won't be asked.

enjoy! ;-)

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.