I have the following code
and my question is
Do i use a Autoexec to fire this ?
As: fGetLinkedTable s("ODBC")
Or how do i ?? do i replace the above as
fGetLinkedTable s("test_be")
Or ???
thanks in advance for any help
' 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_NOREMOTETA BLE = vbObjectError + 2000
On Local Error GoTo fRefreshLinks_E rr
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 = fGetLinkedTable s
'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("Pl ease select a new datasource")
Else
strNewPath = vbNullString
End If
For i = collTbls.Count To 1 Step -1
strDBPath = fParsePath(coll Tbls(i))
strTbl = fParseTable(col lTbls(i))
varRet = SysCmd(acSysCmd SetStatus, "Now linking '" & strTbl &
"'....")
If Left$(strDBPath , 4) = "ODBC" Then
'ODBC Tables
'ODBC Tables handled separately
' Set tdfLocal = dbCurr.TableDef s(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(strDBPa th)) = 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).Ope nDatabase(strDB Path)
'check to see if the table is present in dbLink
strTbl = fParseTable(col lTbls(i))
If fIsRemoteTable( dbLink, strTbl) Then
'everything's ok, reconnect
Set tdfLocal = dbCurr.TableDef s(strTbl)
With tdfLocal
.Connect = ";Database= " & strDBPath
.RefreshLink
collTbls.Remove (.name)
End With
Else
Err.Raise cERR_NOREMOTETA BLE
End If
End If
Next
fRefreshLinks = True
varRet = SysCmd(acSysCmd ClearStatus)
MsgBox "All Access tables were successfully reconnected.", _
vbInformation + vbOKOnly, _
"Success"
fRefreshLinks_E nd:
Set collTbls = Nothing
Set tdfLocal = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_E rr:
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_E nd
Case cERR_NOREMOTETA BLE:
MsgBox "Table '" & strTbl & "' was not found in the
database" & _
vbCrLf & dbLink.name & ". Couldn't refresh links",
_
vbCritical + vbOKOnly, _
"Error in refreshing links."
Resume fRefreshLinks_E nd
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Descriptio n: " & Err.Description &
vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Num ber) &
vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical, "Error"
Resume fRefreshLinks_E nd
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.TableD efs(strTbl)
fIsRemoteTable = (Err = 0)
Set tdf = Nothing
End Function
Function fGetMDBName(str In As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String
strFilter = ahtAddFilterIte m(strFilter, _
"Access Database(*.mdb; *.mda;*.mde;*.m dw) ", _
"*.mdb; *.mda; *.mde; *.mdw")
strFilter = ahtAddFilterIte m(strFilter, _
"All Files (*.*)", _
"*.*")
fGetMDBName = ahtCommonFileOp enSave(Filter:= strFilter, _
OpenFile:=True, _
DialogTitle:=st rIn, _
Flags:=ahtOFN_H IDEREADONLY)
End Function
Function fGetLinkedTable s() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As Database
Set db = CurrentDb
db.TableDefs.re fresh
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 fGetLinkedTable s = collTables
Set collTables = Nothing
Set tdf = Nothing
Set db = Nothing
End Function
Function fParsePath(strI n 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(str In As String) As String
fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
and my question is
Do i use a Autoexec to fire this ?
As: fGetLinkedTable s("ODBC")
Or how do i ?? do i replace the above as
fGetLinkedTable s("test_be")
Or ???
thanks in advance for any help
' 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_NOREMOTETA BLE = vbObjectError + 2000
On Local Error GoTo fRefreshLinks_E rr
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 = fGetLinkedTable s
'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("Pl ease select a new datasource")
Else
strNewPath = vbNullString
End If
For i = collTbls.Count To 1 Step -1
strDBPath = fParsePath(coll Tbls(i))
strTbl = fParseTable(col lTbls(i))
varRet = SysCmd(acSysCmd SetStatus, "Now linking '" & strTbl &
"'....")
If Left$(strDBPath , 4) = "ODBC" Then
'ODBC Tables
'ODBC Tables handled separately
' Set tdfLocal = dbCurr.TableDef s(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(strDBPa th)) = 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).Ope nDatabase(strDB Path)
'check to see if the table is present in dbLink
strTbl = fParseTable(col lTbls(i))
If fIsRemoteTable( dbLink, strTbl) Then
'everything's ok, reconnect
Set tdfLocal = dbCurr.TableDef s(strTbl)
With tdfLocal
.Connect = ";Database= " & strDBPath
.RefreshLink
collTbls.Remove (.name)
End With
Else
Err.Raise cERR_NOREMOTETA BLE
End If
End If
Next
fRefreshLinks = True
varRet = SysCmd(acSysCmd ClearStatus)
MsgBox "All Access tables were successfully reconnected.", _
vbInformation + vbOKOnly, _
"Success"
fRefreshLinks_E nd:
Set collTbls = Nothing
Set tdfLocal = Nothing
Set dbLink = Nothing
Set dbCurr = Nothing
Exit Function
fRefreshLinks_E rr:
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_E nd
Case cERR_NOREMOTETA BLE:
MsgBox "Table '" & strTbl & "' was not found in the
database" & _
vbCrLf & dbLink.name & ". Couldn't refresh links",
_
vbCritical + vbOKOnly, _
"Error in refreshing links."
Resume fRefreshLinks_E nd
Case Else:
strMsg = "Error Information..." & vbCrLf & vbCrLf
strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
strMsg = strMsg & "Descriptio n: " & Err.Description &
vbCrLf
strMsg = strMsg & "Error #: " & Format$(Err.Num ber) &
vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical, "Error"
Resume fRefreshLinks_E nd
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.TableD efs(strTbl)
fIsRemoteTable = (Err = 0)
Set tdf = Nothing
End Function
Function fGetMDBName(str In As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String
strFilter = ahtAddFilterIte m(strFilter, _
"Access Database(*.mdb; *.mda;*.mde;*.m dw) ", _
"*.mdb; *.mda; *.mde; *.mdw")
strFilter = ahtAddFilterIte m(strFilter, _
"All Files (*.*)", _
"*.*")
fGetMDBName = ahtCommonFileOp enSave(Filter:= strFilter, _
OpenFile:=True, _
DialogTitle:=st rIn, _
Flags:=ahtOFN_H IDEREADONLY)
End Function
Function fGetLinkedTable s() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As Database
Set db = CurrentDb
db.TableDefs.re fresh
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 fGetLinkedTable s = collTables
Set collTables = Nothing
Set tdf = Nothing
Set db = Nothing
End Function
Function fParsePath(strI n 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(str In As String) As String
fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
Comment