C
Cyberwolf0000 via AccessMonster.com
I am currently using fRefreshLinks() to update my links in a database I use.
I had to modify it because I am copying a development db into live and need
to update the links to the live tables. That was no problem. What I would
really like to do is do this from another database that I use to track my
different projects and what have you for the company. I have been unable to
figure out what needs to be modified so that it doesn't actually open and
lock the database I want to update links in.
Here is the code I use currently.
<code>
'***************** 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))
'Checks the table name and assigns the strNewPath with the proper
backend database
If Left(strTbl, 3) = "tbl" Then
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
CMTracking_be.mdb"
ElseIf Left(strTbl, 3) = "aud" Or strTbl = "UpdateTables" Then
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
RAMP_Audit.mdb"
Else
Select Case strTbl
Case "Departments", "Employees"
strNewPath = "\\chf-fnp-file01\pool$\Training db\Training_be.
mdb"
Case "PivotPlates"
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
OutsideData\PPU\PPUDAILY.mdb"
Case Else
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
RAMP_be.mdb"
End Select
End If
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 fGetLinkedTables() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As Database
Set db = OpenDatabase("\\chf-fnp-file01\Pool$\Database Programming\
AccessFE\RAMP_fe.mdb")
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 ***************
</code>
I thought that by editing this line
'now link all of them
Set dbCurr = CurrentDb
to point to the proper location that it would work. The only way I cauld get
it to do that was by using the "OpenDatabase" method. But that puts the db
in a locked state.
Any help would be greatly appreciated.
--
James B Gaylord
For the Wolf comes the strength of the Pack,
For the Pack comes the strength of the Wolf,
-R. Kipling
Office 2003 on Win XP SP2
I had to modify it because I am copying a development db into live and need
to update the links to the live tables. That was no problem. What I would
really like to do is do this from another database that I use to track my
different projects and what have you for the company. I have been unable to
figure out what needs to be modified so that it doesn't actually open and
lock the database I want to update links in.
Here is the code I use currently.
<code>
'***************** 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))
'Checks the table name and assigns the strNewPath with the proper
backend database
If Left(strTbl, 3) = "tbl" Then
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
CMTracking_be.mdb"
ElseIf Left(strTbl, 3) = "aud" Or strTbl = "UpdateTables" Then
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
RAMP_Audit.mdb"
Else
Select Case strTbl
Case "Departments", "Employees"
strNewPath = "\\chf-fnp-file01\pool$\Training db\Training_be.
mdb"
Case "PivotPlates"
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
OutsideData\PPU\PPUDAILY.mdb"
Case Else
strNewPath = "\\chf-fnp-file01\pool$\Database Programming\
RAMP_be.mdb"
End Select
End If
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 fGetLinkedTables() As Collection
'Returns all linked tables
Dim collTables As New Collection
Dim tdf As TableDef, db As Database
Set db = OpenDatabase("\\chf-fnp-file01\Pool$\Database Programming\
AccessFE\RAMP_fe.mdb")
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 ***************
</code>
I thought that by editing this line
'now link all of them
Set dbCurr = CurrentDb
to point to the proper location that it would work. The only way I cauld get
it to do that was by using the "OpenDatabase" method. But that puts the db
in a locked state.
Any help would be greatly appreciated.
--
James B Gaylord
For the Wolf comes the strength of the Pack,
For the Pack comes the strength of the Wolf,
-R. Kipling
Office 2003 on Win XP SP2