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

vba ms-access ms-access-2007

add a comment

up vote 2 down vote accepted

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