A
Al
I need to make a form with a button that allows the user to relink tables to
a different Access database on the fly.
can someone help?
thanks
Al
a different Access database on the fly.
can someone help?
thanks
Al
You are using an out of date browser. It may not display this or other websites correctly.
You should upgrade or use an alternative browser.
You should upgrade or use an alternative browser.
P
Pendragon
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
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
T
Tony Toews [MVP]
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.
Relink Access tables from code
http://www.mvps.org/access/tables/tbl0009.htm
You'll have to do some wrapper functions as well such as
Call the standard Windows File Open/Save dialog box
http://www.mvps.org/access/api/api0001.htm
Tony
--
Tony Toews, Microsoft Access MVP
Please respond only in the newsgroups so that others can
read the entire thread of messages.
Microsoft Access Links, Hints, Tips & Accounting Systems at
http://www.granite.ab.ca/accsmstr.htm
Tony's Microsoft Access Blog - http://msmvps.com/blogs/access/
A
Al
thank you. It works
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
Ask a Question
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.