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
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