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