<br><font size=2><tt>Call fRefreshLinks</tt></font>
<br>
<br><font size=2><tt>Option Compare Database</tt></font>
<br><font size=2><tt>Option Explicit</tt></font>
<br>
<br><font size=2><tt>Function fRefreshLinks() As Boolean</tt></font>
<br><font size=2><tt>Dim strMsg As String, collTbls As Collection</tt></font>
<br><font size=2><tt>Dim i As Integer, strDBPath As String, strTbl As String</tt></font>
<br><font size=2><tt>Dim dbCurr As Database, dbLink As Database</tt></font>
<br><font size=2><tt>Dim tdfLocal As TableDef</tt></font>
<br><font size=2><tt>Dim varRet As Variant</tt></font>
<br><font size=2><tt>Dim strNewPath As String</tt></font>
<br>
<br><font size=2><tt>Const cERR_USERCANCEL = vbObjectError + 1000</tt></font>
<br><font size=2><tt>Const cERR_NOREMOTETABLE = vbObjectError + 2000</tt></font>
<br>
<br><font size=2><tt> On Local Error GoTo fRefreshLinks_Err</tt></font>
<br>
<br><font size=2><tt> </tt></font>
<br><font size=2><tt> 'First get all linked tables in a collection</tt></font>
<br><font size=2><tt> Set collTbls = fGetLinkedTables</tt></font>
<br>
<br><font size=2><tt> 'now link all of them</tt></font>
<br><font size=2><tt> Set dbCurr = CurrentDb</tt></font>
<br>
<br><font size=2><tt> 'strMsg = "Do you wish to specify a different path for the Access Tables?"</tt></font>
<br><font size=2><tt>'If MsgBox(strMsg, vbQuestion + vbYesNo, "Alternate data source...") = vbYes</tt></font>
<br><font size=2><tt>'Then strNewPath = fGetMDBName("Please select a new datasource") Else</tt></font>
<br><font size=2><tt>'strNewPath = vbNullString End If</tt></font>
<br><font size=2><tt>strNewPath = GetDataLoc & GetDataName</tt></font>
<br>
<br><font size=2><tt> For i = collTbls.Count To 1 Step -1</tt></font>
<br><font size=2><tt> strDBPath = fParsePath(collTbls(i))</tt></font>
<br><font size=2><tt> strTbl = fParseTable(collTbls(i))</tt></font>
<br><font size=2><tt> varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")</tt></font>
<br><font size=2><tt> If left$(strDBPath, 4) = "ODBC" Then</tt></font>
<br><font size=2><tt> 'ODBC Tables</tt></font>
<br><font size=2><tt> 'ODBC Tables handled separately</tt></font>
<br><font size=2><tt> ' Set tdfLocal = dbCurr.TableDefs(strTbl)</tt></font>
<br><font size=2><tt> ' With tdfLocal</tt></font>
<br><font size=2><tt> ' .Connect = pcCONNECT</tt></font>
<br><font size=2><tt> ' .RefreshLink</tt></font>
<br><font size=2><tt> ' collTbls.Remove (strTbl)</tt></font>
<br><font size=2><tt> ' End With</tt></font>
<br><font size=2><tt> Else</tt></font>
<br><font size=2><tt> If strNewPath <> vbNullString Then</tt></font>
<br><font size=2><tt> 'Try this first</tt></font>
<br><font size=2><tt> strDBPath = strNewPath</tt></font>
<br><font size=2><tt> Else</tt></font>
<br><font size=2><tt> If Len(Dir(strDBPath)) = 0 Then</tt></font>
<br><font size=2><tt> 'File Doesn't Exist, call GetOpenFileName</tt></font>
<br><font size=2><tt> strDBPath = fGetMDBName("'" & strDBPath & "' not found.")</tt></font>
<br><font size=2><tt> If strDBPath = vbNullString Then</tt></font>
<br><font size=2><tt> 'user pressed cancel</tt></font>
<br><font size=2><tt> Err.Raise cERR_USERCANCEL</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> End If</tt></font>
<br>
<br><font size=2><tt> 'backend database exists</tt></font>
<br><font size=2><tt> 'putting it here since we could have</tt></font>
<br><font size=2><tt> 'tables from multiple sources</tt></font>
<br><font size=2><tt> Set dbLink = DBEngine(0).OpenDatabase(strDBPath)</tt></font>
<br>
<br><font size=2><tt> 'check to see if the table is present in dbLink</tt></font>
<br><font size=2><tt> strTbl = fParseTable(collTbls(i))</tt></font>
<br><font size=2><tt> If fIsRemoteTable(dbLink, strTbl) Then</tt></font>
<br><font size=2><tt> 'everything's ok, reconnect</tt></font>
<br><font size=2><tt> Set tdfLocal = dbCurr.TableDefs(strTbl)</tt></font>
<br><font size=2><tt> With tdfLocal</tt></font>
<br><font size=2><tt> .Connect = ";Database=" & strDBPath</tt></font>
<br><font size=2><tt> .RefreshLink</tt></font>
<br><font size=2><tt> collTbls.Remove (.name)</tt></font>
<br><font size=2><tt> End With</tt></font>
<br><font size=2><tt> Else</tt></font>
<br><font size=2><tt> Err.Raise cERR_NOREMOTETABLE</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> Next</tt></font>
<br><font size=2><tt> fRefreshLinks = True</tt></font>
<br><font size=2><tt> varRet = SysCmd(acSysCmdClearStatus)</tt></font>
<br><font size=2><tt> MsgBox "All Access tables were successfully reconnected.", vbInformation + vbOKOnly, "Success"</tt></font>
<br><font size=2><tt>fRefreshLinks_End:</tt></font>
<br><font size=2><tt> Set collTbls = Nothing</tt></font>
<br><font size=2><tt> Set tdfLocal = Nothing</tt></font>
<br><font size=2><tt> Set dbLink = Nothing</tt></font>
<br><font size=2><tt> Set dbCurr = Nothing</tt></font>
<br><font size=2><tt> Exit Function</tt></font>
<br><font size=2><tt>fRefreshLinks_Err:</tt></font>
<br><font size=2><tt> fRefreshLinks = False</tt></font>
<br><font size=2><tt> Select Case Err</tt></font>
<br><font size=2><tt> Case 3059:</tt></font>
<br>
<br><font size=2><tt> Case cERR_USERCANCEL:</tt></font>
<br><font size=2><tt> MsgBox "No Database was specified, couldn't link tables.", _</tt></font>
<br><font size=2><tt> vbCritical + vbOKOnly, _</tt></font>
<br><font size=2><tt> "Error in refreshing links."</tt></font>
<br><font size=2><tt> Resume fRefreshLinks_End</tt></font>
<br><font size=2><tt> Case cERR_NOREMOTETABLE:</tt></font>
<br><font size=2><tt> MsgBox "Table '" & strTbl & "' was not found in the database" & _</tt></font>
<br><font size=2><tt> vbCrLf & dbLink.name & ". Couldn't refresh links", _</tt></font>
<br><font size=2><tt> vbCritical + vbOKOnly, _</tt></font>
<br><font size=2><tt> "Error in refreshing links."</tt></font>
<br><font size=2><tt> Resume fRefreshLinks_End</tt></font>
<br><font size=2><tt> Case Else:</tt></font>
<br><font size=2><tt> strMsg = "Error Information..." & vbCrLf & vbCrLf</tt></font>
<br><font size=2><tt> strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf</tt></font>
<br><font size=2><tt> strMsg = strMsg & "Description: " & Err.Description & vbCrLf</tt></font>
<br><font size=2><tt> strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf</tt></font>
<br><font size=2><tt> MsgBox strMsg, vbOKOnly + vbCritical, "Error"</tt></font>
<br><font size=2><tt> Resume fRefreshLinks_End</tt></font>
<br><font size=2><tt> End Select</tt></font>
<br><font size=2><tt>End Function</tt></font>
<br>
<br><font size=2><tt>Function fIsRemoteTable(dbRemote As Database, strTbl As String) As Boolean</tt></font>
<br><font size=2><tt>Dim tdf As TableDef</tt></font>
<br><font size=2><tt> On Error Resume Next</tt></font>
<br><font size=2><tt> Set tdf = dbRemote.TableDefs(strTbl)</tt></font>
<br><font size=2><tt> fIsRemoteTable = (Err = 0)</tt></font>
<br><font size=2><tt> Set tdf = Nothing</tt></font>
<br><font size=2><tt>End Function</tt></font>
<br>
<br><font size=2><tt>Function fGetMDBName(strIn As String) As String</tt></font>
<br><font size=2><tt>'Calls GetOpenFileName dialog</tt></font>
<br><font size=2><tt>Dim strFilter As String</tt></font>
<br>
<br><font size=2><tt> 'strFilter = ahtAddFilterItem(strFilter, "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", "*.mdb; *.mda; *.mde; *.mdw")</tt></font>
<br><font size=2><tt> 'strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")</tt></font>
<br><font size=2><tt> 'fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, OpenFile:=True, DialogTitle:=strIn, Flags:=ahtOFN_HIDEREADONLY)</tt></font>
<br><font size=2><tt>End Function</tt></font>
<br>
<br><font size=2><tt>Function fGetLinkedTables() As Collection</tt></font>
<br><font size=2><tt>'Returns all linked tables</tt></font>
<br><font size=2><tt> Dim collTables As New Collection</tt></font>
<br><font size=2><tt> Dim tdf As TableDef, db As Database</tt></font>
<br><font size=2><tt> Set db = CurrentDb</tt></font>
<br><font size=2><tt> db.TableDefs.Refresh</tt></font>
<br><font size=2><tt> For Each tdf In db.TableDefs</tt></font>
<br><font size=2><tt> With tdf</tt></font>
<br><font size=2><tt> If Len(.Connect) > 0 Then</tt></font>
<br><font size=2><tt> If left$(.Connect, 4) = "ODBC" Then</tt></font>
<br><font size=2><tt> ' collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name</tt></font>
<br><font size=2><tt> 'ODBC Reconnect handled separately</tt></font>
<br><font size=2><tt> Else</tt></font>
<br><font size=2><tt> collTables.Add Item:=.name & .Connect, KEY:=.name</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt> End With</tt></font>
<br><font size=2><tt> Next</tt></font>
<br><font size=2><tt> Set fGetLinkedTables = collTables</tt></font>
<br><font size=2><tt> Set collTables = Nothing</tt></font>
<br><font size=2><tt> Set tdf = Nothing</tt></font>
<br><font size=2><tt> Set db = Nothing</tt></font>
<br><font size=2><tt>End Function</tt></font>
<br>
<br><font size=2><tt>Function fParsePath(strIn As String) As String</tt></font>
<br><font size=2><tt> If left$(strIn, 4) <> "ODBC" Then</tt></font>
<br><font size=2><tt> fParsePath = right(strIn, Len(strIn) _</tt></font>
<br><font size=2><tt> - (InStr(1, strIn, "DATABASE=") + 8))</tt></font>
<br><font size=2><tt> Else</tt></font>
<br><font size=2><tt> fParsePath = strIn</tt></font>
<br><font size=2><tt> End If</tt></font>
<br><font size=2><tt>End Function</tt></font>
<br>
<br><font size=2><tt>Function fParseTable(strIn As String) As String</tt></font>
<br><font size=2><tt> fParseTable = left$(strIn, InStr(1, strIn, ";") - 1)</tt></font>
<br><font size=2><tt>End Function</tt></font><font size=2 face="Courier New"><br>
</font>
<br>
<br>
<br>
<table width=100%>
<tr valign=top>
<td>
<td><font size=1 face="sans-serif"><b>"Christopher Hawkins" <clh@christopherhawkins.com></b></font>
<br><font size=1 face="sans-serif">Sent by: accessd-bounces@databaseadvisors.com</font>
<p><font size=1 face="sans-serif">06/05/2003 02:06 PM</font>
<br><font size=1 face="sans-serif">Please respond to accessd</font>
<br>
<td><font size=1 face="Arial"> </font>
<br><font size=1 face="sans-serif"> To: accessd@databaseadvisors.com</font>
<br><font size=1 face="sans-serif"> cc: </font>
<br><font size=1 face="sans-serif"> Subject: [AccessD] Fast back-end relinking?</font></table>
<br>
<br>
<br><font size=2 face="Courier New">First off: I have seen (and used) Tribble's Back-End relinker<br>
before. That's not what I need in this case.<br>
<br>
I have inherited an app with some back-end relinking code that is<br>
very slow. I've seen programmatic implementations of a table link<br>
that linked up very quickly, as quickly as using File > Get External<br>
Data > Link Tables. The one I'm dealing with takes many times as<br>
long.<br>
<br>
There is a table in my db called tblTable. It contains the name and<br>
path of every table in the database. The table is used in the<br>
following code:<br>
<br>
***START***<br>
<br>
Dim db As DAO.Database<br>
Dim tbl As DAO.TableDef<br>
Set db = CurrentDb<br>
Dim rsData As DAO.Recordset<br>
<br>
<br>
Set rsData = db.OpenRecordset("SELECT * FROM tblTable")<br>
<br>
rsData.MoveFirst<br>
<br>
Do Until rsData.EOF = True<br>
Set tbl = db.CreateTableDef(rsData("TableName"))<br>
Debug.Print "Now attaching " & tbl.Name & "..."<br>
tbl.Connect = (";DATABASE=" & rsData("Path"))<br>
tbl.SourceTableName = rsData("TableName")<br>
db.TableDefs.Append tbl<br>
rsData.MoveNext<br>
Loop<br>
<br>
db.Close<br>
<br>
***END***<br>
<br>
All the lag takes place when running the 'db.TableDefs.append tbl'<br>
line.<br>
<br>
Is there any way to speed this process up? I've seen it done more<br>
quickly before, I just didn't get to see the actual code. :(<br>
<br>
-Christopher-<br>
<br>
_______________________________________________<br>
AccessD mailing list<br>
AccessD@databaseadvisors.com<br>
http://databaseadvisors.com/mailman/listinfo/accessd<br>
Website: http://www.databaseadvisors.com<br>
<br>
</font>
<br>
<br>