MyTetra Share
Делитесь знаниями!
Linking tables through vba
Время создания: 16.03.2019 23:43
Текстовые метки: Append, TableDef, access, Link
Раздел: !Закладки - VBA - Access - Link
Запись: xintrea/mytetra_db_adgaver_new/master/base/1515393052mwvrzoyzp5/text.html на

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


End Function

vba ms-access ms-access-2007

s hareimprove this question

add a comment

1 Answer

a ctive oldest votes

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.


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 AS [Schema], sys.objects.*, + '.' + 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) " & _


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


If Not .EOF Then



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"


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


End With

End If

End If

TEnd = PerfTimer()

AppendTxtMain SplitTime(TEnd - TStart, 7, "s")


prgProgress = prgProgress + 1

CtrA = CtrA + 1


End With

prgProgress = 0

prgProgress.Max = dDB.TableDefs.Count



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


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


TEnd = PerfTimer()

AppendTxtMain "Completed at " & Now() & " in " & SplitTime(TEnd - TStart, 7, "s"), True


drSysVars![SchemaUpdated] = ObjectTime





Set drSQLSchemas = Nothing


Set arSQLObjects = Nothing


Set adoConn = Nothing


Set drSysVars = Nothing


Set drMSO = Nothing


Set dDB = Nothing


Set dWS = Nothing

prgProgress = 0

End Sub

s hareimprove this answer

edited Jun 23 '14 at 23:26

Так же в этом разделе:
MyTetra Share v.0.60
Яндекс индекс цитирования