Heenan, Lambert
Lambert.Heenan at chartisinsurance.com
Fri Aug 28 14:59:14 CDT 2009
Jim,
FWIW here is the code I use. Note that I have commented out the function fGetMDBName as it uses a class module to display a file selection dialog. Replace with your own favorite routine.
This routine makes use of a table, that is local to the front end, called "USYS_LinkedTables_tbl". It has the following structure...
ID: Autonumber
strTableName: Text (255) ' full name of each linked table
strBackEndPath: Text (255) ' full path to production version of the back end(s), including mdb file name
strBackEndPath: Text (255) ' full path to development versions of the back end(s), including mdb file name
So to re-link to the production data (which may include any number of different back-ends) call the function like this...
strResult = fRefreshLinks("Production")
HTH
Lambert
'Code Starts
'======================================
Option Compare Database
Option Explicit
Function fRefreshLinks(strLinkTarget As String) As String
' returns an empty string on success or a string with error messages
Dim collTbls As Collection ' a collection of table names and connection strings, some tagged as non-access
Dim i As Integer ' loop counter
Dim strDBPath As String '
Dim strTbl As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdfLocal As TableDef
Dim strTableAlias As String
Dim varRet As Variant
Dim strNewPath As String
Dim strCriteria As String
Dim rsLinks As DAO.Recordset
Dim db As DAO.Database
Dim bLiveData As Boolean
Dim strReturnValue As String
Const cERR_USERCANCEL = vbObjectError + 1
Const cERR_NOREMOTETABLE = vbObjectError + 2
Const cERR_TABLE_LINK_NOTFOUND = vbObjectError + 3
10 On Local Error GoTo fRefreshLinks_Err
'First get all linked tables in a collection
20 Set collTbls = fGetLinkedTables
30 Set db = CurrentDb
40 Set rsLinks = db.OpenRecordset("USYS_LinkedTables_tbl")
'now link all of them
50 Set dbCurr = CurrentDb
60 If strLinkTarget = "Production" Then
70 bLiveData = True
80 Else
90 bLiveData = False
100 End If
110 For i = collTbls.Count To 1 Step -1
120 strDBPath = fParsePath(collTbls(i))
130 strTbl = fParseTable(collTbls(i))
140 strTableAlias = Nz(Field(collTbls(i), "@", 3), "")
150 varRet = SysCmd(acSysCmdSetStatus, "Now linking '" & strTbl & "'....")
160 If strTableAlias > "" Then
170 strCriteria = "strTableName='" & strTableAlias & "'"
180 Else
190 strCriteria = "strTableName='" & strTbl & "'"
200 End If
210 With rsLinks
220 .FindFirst strCriteria
230 If Not .NoMatch Then
240 strNewPath = IIf(bLiveData, !strBackEndPath, !strDevBackEndPath) ' get our path, Live or Dev data
250 Else
260 strNewPath = vbNullString
270 Err.Raise cERR_TABLE_LINK_NOTFOUND
280 End If
290 End With
300 If Left$(strDBPath, 4) = "ODBC" Then
'ODBC Tables
'ODBC Tables not being handled by this code
310 Else
320 If strNewPath <> vbNullString Then
'Try this first
330 strDBPath = strNewPath
340 Else
350 If Len(Dir(strDBPath)) = 0 Then
'File Doesn't Exist, call GetOpenFileName
360 strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
370 If strDBPath = vbNullString Then
'user pressed cancel
380 Err.Raise cERR_USERCANCEL
390 End If
400 End If
410 End If
420 Set dbLink = DBEngine(0).OpenDatabase(strDBPath)
'check to see if the table is present in dbLink
430 strTbl = fParseTable(collTbls(i))
440 If fIsRemoteTable(dbLink, strTbl) Then
'everything's ok, reconnect
450 If strTableAlias > "" Then
460 Set tdfLocal = dbCurr.TableDefs(strTableAlias)
470 Else
480 Set tdfLocal = dbCurr.TableDefs(strTbl)
490 End If
500 With tdfLocal
510 .Connect = ";Database=" & strDBPath
520 .RefreshLink
530 collTbls.Remove (.Name)
540 End With
550 Else
560 Err.Raise cERR_NOREMOTETABLE
570 End If
580 End If
590 Next
600 Set db = Nothing
610 Set rsLinks = Nothing
620 If Not strReturnValue > "" Then
630 strReturnValue = "All Access tables were successfully reconnected."
640 End If
fRefreshLinks_End:
650 varRet = SysCmd(acSysCmdClearStatus)
660 Set collTbls = Nothing
670 Set tdfLocal = Nothing
680 Set dbLink = Nothing
690 Set dbCurr = Nothing
700 fRefreshLinks = strReturnValue
710 Exit Function
fRefreshLinks_Err:
720 fRefreshLinks = False
730 Select Case Err
Case 3059:
740 Case cERR_USERCANCEL:
750 strReturnValue = strReturnValue & "No Database was specified, couldn't link tables." & vbCrLf
760 Resume fRefreshLinks_End
770 Case cERR_NOREMOTETABLE:
780 strReturnValue = strReturnValue & "Table '" & strTbl & "' was not found in the Database " & dbLink.Name & vbCrLf
790 Resume Next
800 Case cERR_TABLE_LINK_NOTFOUND
810 strReturnValue = strReturnValue & "Link to " & strTbl & " not found in master table USYS_LinkedTables_tbl." & vbCrLf
820 Resume Next
830 Case Else:
840 strReturnValue = strReturnValue & "Error Information..." & vbCrLf & vbCrLf _
& "Function: fRefreshLinks" & vbCrLf _
& "Description: " & Err.Description & vbCrLf _
& "Error #: " & Format$(Err.Number) & vbCrLf & "ERL=" & Erl & vbCrLf
850 Resume Next
860 End Select
End Function
Function fIsRemoteTable(dbRemote As DAO.Database, strTbl As String) As Boolean
Dim tdf As TableDef
10 On Error Resume Next
20 Set tdf = dbRemote.TableDefs(strTbl)
30 fIsRemoteTable = (Err = 0)
40 Set tdf = Nothing
End Function
Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
'Dim fDlg As New clsCommonDialogs
'10 With fDlg
'20 .AddFilterItem "Access Database(*.mdb;*.mda;*.mde;*.mdw) ", "*.mdb; *.mda; *.mde; *.mdw"
'30 .AddFilterItem "All Files (*.*)", "*.*"
'40 fGetMDBName = Nz(.GetOpenFile(, strIn), "")
'50 End With
End Function
Function fGetLinkedTables() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As DAO.Database
10 Set db = CurrentDb
20 db.TableDefs.Refresh
30 For Each tdf In db.TableDefs
40 With tdf
50 If Len(.Connect) > 0 Then
60 If Left$(.Connect, 4) = "ODBC" Then
' collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
'ODBC Reconnect handled separately
70 Else
80 If .Name <> .SourceTableName Then
90 collTables.Add Item:=.SourceTableName & .Connect & "@ALIAS@" & .Name, Key:=.Name
100 Else
110 collTables.Add Item:=.Name & .Connect, Key:=.Name
120 End If
130 End If
140 End If
150 End With
160 Next
170 Set fGetLinkedTables = collTables
180 Set collTables = Nothing
190 Set tdf = Nothing
200 Set db = Nothing
End Function
Function fParsePath(strIn As String) As String
Dim strTmp As String
10 If Left$(strIn, 4) <> "ODBC" Then
20 strTmp = Right(strIn, Len(strIn) _
- (InStr(1, strIn, "Database=") + 8))
30 If InStr(strTmp, "@") > 0 Then
40 strTmp = Field(strTmp, "@", 1)
50 End If
60 fParsePath = strTmp
70 Else
80 fParsePath = strIn
90 End If
End Function
Function fParseTable(strIn As String) As String
10 fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Code End ***************
Function Field(ByVal strSource As String, strSep As String, intN As Integer) As Variant
'Purpose:
' Returns the Nth element in a delimited list.
' Input: strSource - the list to search
' strSep - the delimiter of the list - can be more than one character
' intN - the ordinal value of the element to be returned
'
' Null is returned if either string parameter is null, or intN <=0 or
' If the separator string is not found
'
'Str = Field("Chuck*Roberts","*",1) would return "Chuck".
Dim strResult As String
Dim strSearch As String
Dim i As Long
Dim lSep As Long
lSep = 0: i = 0
If IsNull(strSource) Or strSource = "" Or IsNull(strSep) Or strSep = "" Or intN <= 0 Then
strResult = ""
Else
strSearch = strSource
While i < intN
lSep = InStr(strSearch, strSep)
If lSep > 0 Then ' we found the delimiter string
i = i + 1 ' count occurance
If i = intN Then ' this is the one we want
strResult = Left$(strSearch, lSep - 1)
End If
' strip off i'th field
strSearch = Right(strSearch, Len(strSearch) - (lSep + Len(strSep) - 1))
Else ' did not find our separator string, so return the remainer of the string if the count is ok
If i = intN - 1 Then ' we have seen N-1 separator strings, so this is the field we want
' at the end of the search string
i = i + 1 ' to terminate the While loop
strResult = strSearch
Else ' there were less than N-1 fields in the input to return Null
strResult = ""
i = intN
End If
End If
Wend
End If
If strResult = "" Then
Field = Null
Else
Field = strResult
End If
End Function
' Code ends
'================================================