B
Brett Barry: Go Get Geek!
I am having problems trying to automate the refresh of linked tables.
I have two tables linked to Excel spreadsheets. Since these
spreadsheets are exported from different files in the same program,
they need to be refreshed just in case the user doesn't name the
exported Excel files the same and/or doesn't puts them in the same
location.
I've tried to put in my macro the RunCommand LinkedTableManager, but I
wanted to make sure that the check box is automatically checked for
"Always prompt for new location."
I also tried this code I found, but I get a compile error when I run
the macro with a RunCode for the fRefreshLinks() function, "Compile
error: Sub or Function not defined" and it highlights this function:
Function fGetMDBName(strIn As String) As String and ahtAddFilterItem
in the following module (using Access 2007 with DB in 2003 format
already open):
Option Compare Database
'***************** 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 cERR_USERCANCEL
'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
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
'***************** Code End ***************
Thank you for your help.
I have two tables linked to Excel spreadsheets. Since these
spreadsheets are exported from different files in the same program,
they need to be refreshed just in case the user doesn't name the
exported Excel files the same and/or doesn't puts them in the same
location.
I've tried to put in my macro the RunCommand LinkedTableManager, but I
wanted to make sure that the check box is automatically checked for
"Always prompt for new location."
I also tried this code I found, but I get a compile error when I run
the macro with a RunCode for the fRefreshLinks() function, "Compile
error: Sub or Function not defined" and it highlights this function:
Function fGetMDBName(strIn As String) As String and ahtAddFilterItem
in the following module (using Access 2007 with DB in 2003 format
already open):
Option Compare Database
'***************** 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 cERR_USERCANCEL
'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
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
'***************** Code End ***************
Thank you for your help.