CODEWITHSUNDEEP
vbams-accessms-access-2007
ASM2701
ASM2701

Reputation: 139

Linking tables through vba

I am completing an task that has been assigned to me for my colleagues in the USA (I'm based in the UK). However my database application uses linked Tables to a microsoft access database file over a network that has been encrypted as it stores customer information.

There is no colleague on the USA side with a similar skill set to make any alterations to database locations through VBA. I have seen various methods to connect to SQL databases as shown on the microsoft link below. However, to make it easier for someone to alter the location of the database.

Is it possible to ammend the below code so that will look at a text file which will house the location of the database back end then (C:\users\public\test1) for example and then Link the tables to the front end.

I have found the code below but it errors out saying that "object msysaccessstorage already exists". It errors out on the line "CurrentDb.TableDefs.Append tdf".

Option Explicit
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim mypass As String
Dim mypath As String
Dim myDb As String
Dim TableName As String


Function connectme()

mypass = "test1"
mypath = "C:\Users\Test1\Desktop\"
myDb = "EM1.accdb"

 ' Delete links so there won't be any duplicates
For Each tdf In CurrentDb.TableDefs
If Left(tdf.Name, 4) <> "MSys" And Left(tdf.Name, 15) <> "tblReportsState" And _
(tdf.Attributes And dbAttachedTable) = dbAttachedTable Then
CurrentDb.TableDefs.Delete tdf.Name
End If
Next tdf
Set tdf = Nothing

 ' Setup Links
Set dbs = OpenDatabase(mypath & myDb, False, False, "MS Access;PWD=" & mypass)

For Each tdf In dbs.TableDefs
If Left(tdf.Name, 4) <> "msys" Then
TableName = tdf.Name
Set tdf = CurrentDb.CreateTableDef(TableName)
tdf.Connect = ";PWD=" & mypass & ";Database=" + mypath + myDb
tdf.SourceTableName = TableName
CurrentDb.TableDefs.Append tdf
End If
Next

End Function

Upvotes: 1

Views: 5335

Answers (1)

Monty Wild
Monty Wild

Reputation: 4001

You are probably getting this error because Access' Tabledefs list does not always immediately reflect changes you make, i.e. a delete. You can refresh it with CurrentDB.TableDefs.Refresh after any .Appends and/or .Deletes, but this takes time, and considering that refreshing linked tables takes a significant amount of time each, time is something you may not be able to afford.

It is better practice to check your TableDefs for pre-existing links and refresh them, not delete and recreate them, as deleting them also deletes any formatting, such as column widths and field formats that a refresh would leave unchanged.

If you have tables that need their links refreshed, change the .Connect property, then use CurrentDB.TableDefs(TableName).RefreshLink

You should only be using CurrentDb.TableDefs.Delete tdf.Name when the source table no longer exists.

I use a method similar to this myself, however I also store the date and time of the last linked table refresh, and only refresh those tables that had their schema modified after that time. With a hundred or more table links and 2+ seconds per table to refresh the links, I need to save all the time I can.

EDIT:

The following code is the code I use to perform a similar task linking MS Access to SQL Server.

Disclaimer: The following code is provided as-is, and will not work for a pure Access front-end/back-end situation. It will be necessary to modify it to suit your needs.

Public Sub RefreshLinkedTables()
    Dim adoConn As ADODB.Connection
    Dim arSQLObjects As ADODB.Recordset
    Dim CreateLink As Boolean, UpdateLink As Boolean, Found As Boolean
    Dim dWS As DAO.Workspace
    Dim dDB As DAO.Database
    Dim drSQLSchemas As DAO.Recordset, drSysVars As DAO.Recordset, drMSO As DAO.Recordset
    Dim dTDef As DAO.TableDef
    Dim ObjectTime As Date
    Dim sTStart As Double, sTEnd As Double, TStart As Double, TEnd As Double
    Dim CtrA As Long, ErrNo As Long
    Dim DescStr As String, SQLStr As String, ConnStr As String
    Dim SQLObjects() As String

    sTStart = PerfTimer()
    Set dWS = DBEngine.Workspaces(0)
    Set dDB = dWS.Databases(0)
    Set drSysVars = dDB.OpenRecordset("tbl_SysVars", dbOpenDynaset)
    If drSysVars.RecordCount = 0 Then Exit Sub
    AppendTxtMain "Refreshing Links to """ & drSysVars![ServerName] & """: """ & drSysVars![Database] & """ at " & Format(Now, "hh:mm:ss AMPM"), True
    Set adoConn = SQLConnection()
    Set arSQLObjects = New ADODB.Recordset
    SQLStr = "SELECT sys.schemas.name AS [Schema], sys.objects.*, sys.schemas.name + '.' + sys.objects.name AS SOName " & _
             "FROM sys.objects INNER JOIN sys.schemas ON sys.objects.schema_id = sys.schemas.schema_id " & _
             "WHERE (sys.objects.type IN ('U', 'V')) AND (sys.objects.is_ms_shipped = 0) " & _
             "ORDER BY SOName"
    ObjectTime = Now()
    arSQLObjects.Open SQLStr, adoConn, adOpenStatic, adLockReadOnly, adCmdText
    Set drSQLSchemas = dWS.Databases(0).OpenRecordset("SELECT * FROM USys_tbl_SQLSchemas WHERE LinkObjects = True", dbOpenDynaset)
    Set drMSO = dWS.Databases(0).OpenRecordset("SELECT Name FROM MSysObjects WHERE Type In(1,4,6) ORDER BY Name", dbOpenSnapshot)
    ReDim SQLObjects(0 To arSQLObjects.RecordCount - 1)
    With arSQLObjects
        drMSO.MoveFirst
        If Not .EOF Then
            .MoveLast
            .MoveFirst
        End If
        prgProgress.Max = .RecordCount
        prgProgress = 0
        CtrA = 0
        ConnStr = "DRIVER={SQL Server Native Client 10.0};SERVER=" & drSysVars![ServerName] & ";DATABASE=" & drSysVars![Database]
        If Nz(drSysVars![UserName]) = "" Then
            ConnStr = ConnStr & ";Trusted_Connection=YES"
        Else
            ConnStr = ConnStr & ";Uid=" & drSysVars![UserName] & ";Pwd=" & drSysVars![Password] & ";"
        End If
        Do Until .EOF
            TStart = PerfTimer
            SQLObjects(CtrA) = arSQLObjects![Schema] & "_" & arSQLObjects![Name]
            AppendTxtMain ![SOName] & " (" & ![modify_date] & "): ", True
            drSQLSchemas.FindFirst "[SchemaID] = " & ![schema_id]
            If Not drSQLSchemas.NoMatch Then
                UpdateLink = False
                CreateLink = False
                drMSO.FindFirst "Name=""" & drSQLSchemas![SchemaName] & "_" & arSQLObjects![Name] & """"
                If drMSO.NoMatch Then
                    CreateLink = True
                    AppendTxtMain "Adding Link... "
                    Set dTDef = dDB.CreateTableDef(arSQLObjects![Schema] & "_" & arSQLObjects![Name], dbAttachSavePWD, ![SOName], "ODBC;" & ConnStr)
                    dDB.TableDefs.Append dTDef
                    dDB.TableDefs(dTDef.Name).Properties.Append dTDef.CreateProperty("Description", dbText, "«Autolink»")
                ElseIf ![modify_date] >= Nz(drSysVars![SchemaUpdated], #1/1/1900#) Or RegexMatches(dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name]).Connect, "SERVER=(.+?);")(0).SubMatches(0) <> drSysVars![ServerName] _
                       Or (dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name]).Attributes And dbAttachSavePWD) <> dbAttachSavePWD Then
                    UpdateLink = True
                    AppendTxtMain "Refreshing Link... "
                    With dDB.TableDefs(arSQLObjects![Schema] & "_" & arSQLObjects![Name])
                        .Attributes = dbAttachSavePWD
                        .Connect = "ODBC;" & ConnStr
                        .RefreshLink
                    End With
                End If
            End If
            TEnd = PerfTimer()
            AppendTxtMain SplitTime(TEnd - TStart, 7, "s")
            .MoveNext
            prgProgress = prgProgress + 1
            CtrA = CtrA + 1
        Loop
    End With
    prgProgress = 0
    prgProgress.Max = dDB.TableDefs.Count
    DoEvents
    dDB.TableDefs.Refresh
    TStart = PerfTimer()
    AppendTxtMain "Deleting obsolete linked tables, started " & Now() & "...", True
    For Each dTDef In dDB.TableDefs
        If dTDef.Connect <> "" Then ' Is a linked table...
            On Error Resume Next
            DescStr = dTDef.Properties("Description")
            ErrNo = Err.Number
            On Error GoTo 0
            Select Case ErrNo
                Case 3270   ' Property does not exist
                    ' Do nothing.
                Case 0      ' Has a Description.
                    If RegEx(DescStr, "«Autolink»") Then    ' Description includes "«Autolink»"
                        Found = False
                        For CtrA = 0 To UBound(SQLObjects)
                            If SQLObjects(CtrA) = dTDef.Name Then
                                Found = True
                                Exit For
                            End If
                        Next
                        If Not Found Then   ' Delete if not in arSQLObjects
                            AppendTxtMain "Deleting """ & dTDef.Name & """", True
                            dDB.TableDefs.Delete dTDef.Name
                        End If
                    End If
            End Select
        End If
        prgProgress = prgProgress + 1
    Next
    TEnd = PerfTimer()
    AppendTxtMain "Completed at " & Now() & " in " & SplitTime(TEnd - TStart, 7, "s"), True
    drSysVars.Edit
    drSysVars![SchemaUpdated] = ObjectTime
    drSysVars.Update
    drSQLSchemas.Close
    dDB.TableDefs.Refresh
    Application.RefreshDatabaseWindow
    Set drSQLSchemas = Nothing
    arSQLObjects.Close
    Set arSQLObjects = Nothing
    adoConn.Close
    Set adoConn = Nothing
    drSysVars.Close
    Set drSysVars = Nothing
    drMSO.Close
    Set drMSO = Nothing
    dDB.Close
    Set dDB = Nothing
    dWS.Close
    Set dWS = Nothing
    prgProgress = 0
End Sub

Upvotes: 2

Related Questions