Refreshing Links




I am currently using a bit of code that I found on google... I would like to
alter it a bit to go away quietly if the backend exists in the current
directory. I am not too VBA literate, so any help would be much appreciated.
As it works currently it always asks me if I want to refresh the links.
Naturally I do want to be able to make a choice when the backend is missing

Modules: Misc

Option Compare Database

Public Function GetDBPath() As String
GetDBPath = CurrentProject.Path & "\"
End Function
'***************** Code Start ***************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
' Code Courtesy of
' Dev Ashish
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

If MsgBox("Are you sure you want to reconnect all Access tables?", _
vbQuestion + vbYesNo, "Please confirm...") = vbNo Then Err.Raise

'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")
strNewPath = vbNullString
End If

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
If strNewPath <> vbNullString Then
'Try this first
strDBPath = strNewPath
If Len(Dir(strDBPath)) = 0 Then
'File Doesn't Exist, call GetOpenFileName
strDBPath = fGetMDBName("'" & strDBPath & "' not found.")
If strDBPath = vbNullString Then
'user pressed cancel
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
collTbls.Remove (.Name)
End With
End If
End If
fRefreshLinks = True
varRet = SysCmd(acSysCmdClearStatus)
MsgBox "All Access tables were successfully reconnected.", _
vbInformation + vbOKOnly, _

Set collTbls = Nothing
Set tdfLocal = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks = False
Select Case Err
Case 3059:

MsgBox "No Database was specified, couldn't link tables.", _
vbCritical + vbOKOnly, _
"Error in refreshing links."
Resume fRefreshLinks_End
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, _
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
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
collTables.Add Item:=.Name & .Connect, Key:=.Name
End If
End If
End With
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))
fParsePath = strIn
End If
End Function

Function fParseTable(strIn As String) As String
fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Code End ***************




Ok I tried your code, it seems to be dismissing the refresher .....but it is
not running fRefreshLinks on error. The function(fLookForBE) is executed
through the autoexec. I installed it as a function as follows:

Modules: Misc2

Function fLookForBE() As String
'Look for table: call_list in backend
Dim tdf As TableDef
On Error Resume Next

Set tdf = CurrentDb.TableDefs("call_list")

If Err <> 0 Then
'on error run link refresher
End If

End Function

on open it is creating an error that the backend could not be found...when
the backend is moved. The refresher is not running when the table is not
found....any ideas why?



Alex Dybenko

ok, perhaps I was wrong about tabledef, I checked my code, here how it works
at me:

Dim MyRecords As Recordset

On Error Resume Next
Set MyRecords = currentdb.OpenRecordset("call_list")
If Err = 0 Then
Exit Function
End If


so i trying to open recordset, if no error - then exit function, else - run

Best regards,
Alex Dybenko (MVP)

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.

Ask a Question