Al said:I need to make a form with a button that allows the user to relink tables to
a different Access database on the fly.
Pendragon said:Al,
I inherited a database that switches between source data files based on a
user's selection in a combo box. The initial code was written a while ago
but has worked without issue for me for the last 4 yrs through Office2000 to
Office07.
The code is executed in a command button calling the function below. In my
application, the button is simply btnLink and in the OnClick property, I have
the following:
Dim bRef As Boolean
bRef = fRefreshLinks
In a separate code module, the following functions are listed. Note that
you need to input your information at strNewPath.
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
Set collTbls = fGetLinkedTables
Set dbCurr = CurrentDb
strNewPath = " ****Input your path here**** "
For I = collTbls.Count To 1 Step -1
strDBPath = fParsePath(collTbls(I))
strTbl = fParseTable(collTbls(I))
varRet = SysCmd(acSysCmdSetStatus, "Linking '" & strTbl & "'....")
If Left$(strDBPath, 4) = "ODBC" Then
Else
If strNewPath <> vbNullString Then
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
Set dbLink = DBEngine(0).OpenDatabase(strDBPath)
strTbl = fParseTable(collTbls(I))
If fIsRemoteTable(dbLink, strTbl) Then
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 tables were successfully reconnected.", vbOKOnly
Set collTbls = Nothing
Set tdfLocal = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
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.", vbCritical + vbOKOnly
Resume fRefreshLinks_End
Case cERR_NOREMOTETABLE:
MsgBox "Table '" & strTbl & "' was not found in the database" & _
vbCrLf & dbLink.Name & ".", _
vbCritical + vbOKOnly
Resume fRefreshLinks_End
Case Else:
strMsg = "ERROR:" & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Description: " & Err.Description & vbCrLf
strMsg = strMsg & "Error #: " & Err.Number & vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical
Resume fRefreshLinks_End
End Select
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
Function fGetMDBName(strIn As String) As String
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 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
Want to reply to this thread or ask your own question?
You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.