Linked Tables - Change source data location with code. 2

[jojones]

I have a whole bunch of dbs with linked data which I want to move from my C drive to my D drive for space reasons. I need to be able to change the links in the dbs so they look for the sources on my D drive not my C drive. Is there some way of doing this using code rather than linking tables manually?

thanks
Jo

 

[Guest_imported]

Create modules of the following code and then create a form with a command button that on click executes:
call freshlinks
the modules you need to create are:


Option Compare Database
Option Explicit

Public Sub fExistTable(strTableName As String, strLocation As String)

Dim db As Database
Dim i As Integer
Set db = DBEngine.Workspaces(0).Databases(0)

db.TableDefs.Refresh
For i = 0 To db.TableDefs.Count - 1
If strTableName = db.TableDefs(i).Name Then
'Table Exists

GoTo EXIT_ROUTINE
End If
DoCmd.TransferDatabase acLink, "Microsoft Access", strLocation, acTable, strTableName, strTableName
Next i
Set db = Nothing

EXIT_ROUTINE:

End Sub
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...&quot = 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...&quot = vbYes Then
strNewPath = fGetMDBName("Please select a new datasource&quot
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 & "'....&quot
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(&quot;'&quot; & strDBPath & &quot;' not found.&quot
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 = &quot;;Database=&quot; & strDBPath
.RefreshLink
collTbls.Remove (.Name)
End With
Else
Err.Raise cERR_NOREMOTETABLE
End If
End If
Next
fRefreshLinks = True
varRet = SysCmd(acSysCmdClearStatus)
MsgBox &quot;All Access tables were successfully reconnected.&quot;, vbInformation + vbOKOnly, &quot;Success&quot;
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 &quot;No Database was specified, couldn't link tables.&quot;, _
vbCritical + vbOKOnly, _
&quot;Error in refreshing links.&quot;
Resume fRefreshLinks_End
Case cERR_NOREMOTETABLE:
MsgBox &quot;Table '&quot; & strTbl & &quot;' was not found in the database&quot; & _
vbCrLf & dbLink.Name & &quot;. Couldn't refresh links&quot;, _
vbCritical + vbOKOnly, _
&quot;Error in refreshing links.&quot;
Resume fRefreshLinks_End
Case Else:
strMsg = &quot;Error Information...&quot; & vbCrLf & vbCrLf
strMsg = strMsg & &quot;Function: fRefreshLinks&quot; & vbCrLf
strMsg = strMsg & &quot;Description: &quot; & Err.Description & vbCrLf
strMsg = strMsg & &quot;Error #: &quot; & Format$(Err.Number) & vbCrLf
MsgBox strMsg, vbOKOnly + vbCritical, &quot;Error&quot;
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, _
&quot;Access Database(*.mdb;*.mda;*.mde;*.mdw) &quot;, _
&quot;*.mdb; *.mda; *.mde; *.mdw&quot
strFilter = ahtAddFilterItem(strFilter, _
&quot;All Files (*.*)&quot;, _
&quot;*.*&quot

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) = &quot;ODBC&quot; Then
' collTables.Add Item:=.Name & &quot;;&quot; & .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) <> &quot;ODBC&quot; Then
fParsePath = Right(strIn, Len(strIn) _
- (InStr(1, strIn, &quot;DATABASE=&quot + 8))
Else
fParsePath = strIn
End If
End Function

Function fParseTable(strIn As String) As String
fParseTable = Left$(strIn, InStr(1, strIn, &quot;;&quot - 1)
End Function

 

[jojones]

Thank you very much. I am trying to run this, but getting a Sub or Function not defined on
ahtAddFilterItem
I assume I have to enable a Reference that I don't currently have enabled, but am not sure which one. Can you help?

Jo

 

[Aivars]

Hi Jo!

Here are two simple sub programs for links deleting and creating:

Sub LinksDelete(Optional strConnectString As String = &quot;&quot
'This function removes links to tables with specified connections
'If strConnectString is omitted all links will be removed
Dim tdf As TableDef

For Each tdf In CurrentDb.TableDefs
If tdf.Connect <> &quot;&quot; Then
If InStr(1, tdf.Connect, strConnectString, vbTextCompare) > 0 Then
DoCmd.DeleteObject acTable, tdf.Name
End If
End If
Next tdf
End Sub

'------------------------------------------------------

Sub LinksCreateToSource(strLinkSourceDB As String, _
Optional prpProgressBar As Object)
'This procedure creates links to tables of specified database
'strLinkSourceDB -> full DB path
'You can update progress bar value (optional) if your form have it
'in such case you may include it in the command as second option e.g.:
'Call LinksCreateToSource(&quot;D:\MyDir\MyDB.mdb&quot;, Me.MyProgressbar)

On Error GoTo Err_LinksCreateToSource
Dim dbs As Database
Dim tdf As TableDef

Set dbs = DBEngine.Workspaces(0).OpenDatabase(strLinkSourceDB)

If Not prpProgressBar Is Nothing Then
'Progress bar max value setting
prpProgressBar.Max = dbs.TableDefs.Count
prpProgressBar.Visible = True
End If
For Each tdf In dbs.TableDefs
If Not prpProgressBar Is Nothing Then
'Progress bar value updating
prpProgressBar.Value = prpProgressBar.Value
End If
If Left(tdf.Name, 4) <> &quot;MSys&quot; Then 'Do not create links to the System tables
'Links create
DoCmd.TransferDatabase acLink, _
&quot;Microsoft Access&quot;, strLinkSourceDB, acTable, tdf.Name, tdf.Name
End If
Next tdf
dbs.Close
Set dbs = Nothing

If Not prpProgressBar Is Nothing Then
'Hide progress bar
prpProgressBar.Visible = False
End If

Exit_LinksCreateToSource:
Exit Sub

Err_LinksCreateToSource:
MsgBox &quot;Error No &quot; & Err.Number & vbLf & Error$, , &quot;Sub LinksCreateToSource&quot;
Stop
Resume Exit_LinksCreateToSource

End Sub

Example:
Call LinksDelete
call LinksCreateToSource(&quot;C:\MyDir\MyAccDB.mdb&quot

Easy and fast...
Aivars

 

[billmh]

I want to thank Aivars for this little gift of code. It does the trick for me. I needed a way for customers who may put the backend anywhere. I just used a little code to have have them browse to the BE database and this code did the rest.

Thanks

Bill H.

 

[djmc]

If i have both linked tables and tables that are resident on the current database, does that LinksDelete() subroutine delete the non-linked tables too? If so how can I make it only delete linked tables.

And is there a way to just relink the current linked tables instead of deleting all the linked tables and making new links.

 

[DomFino]

Hi everyone. Thought I would put my two cents in as well. I found this code on the Internet and it works well for me. The credit goes to PETER VUKOVIC.
Dom

Function Reconnect()
'**************************************************************
'* START YOUR APPLICATION (MACRO: AUTOEXEC) WITH THIS FUNCTION*
'* AND THIS PROGRAM WILL CHANGE THE CONNECTIONS AUTOMATICALLY *
'* WHEN THE 'DATA.MDB'  AND THE 'PRG.MDB'                     *
'* ARE IN THE SAME DIRECTORY!!!                               *
'*              PROGRAMMING BY PETER VUKOVIC, Germany         *
'*              100700.1262@compuserve.com                    *
'* ************************************************************
Dim db As Database, source As String, path As String
Dim dbsource As String, i As Integer, j As Integer

Set db = DBEngine.Workspaces(0).Databases(0)
'*************************************************************
'*                     RECOGNIZE THE PATH                    *
'*************************************************************

For i = Len(db.Name) To 1 Step -1
    If MID(db.Name, i, 1) = Chr(92) Then
        path = MID(db.Name, 1, i)
        'MsgBox (path)
        Exit For
    End If
Next
'*************************************************************
'*              CHANGE THE PATH AND CONNECT AGAIN            *
'*************************************************************

For i = 0 To db.TableDefs.Count - 1
    If db.TableDefs(i).Connect <> &quot; &quot; Then
        source = MID(db.TableDefs(i).Connect, 11)
        'Debug.Print source
        For j = Len(source) To 1 Step -1
            If MID(source, j, 1) = Chr(92) Then
               dbsource = MID(source, j + 1, Len(source))
               source = MID(source, 1, j)
                   If source <> path Then
                        db.TableDefs(i).Connect = &quot;;Database=&quot; + path + dbsource
                        db.TableDefs(i).RefreshLink
                        'Debug.Print &quot;;Database=&quot; + path + dbsource
                    End If
                Exit For
            End If
         Next
    End If
Next
End Function

 

[Checking]

Wow DomFino; works like a charm, but it seems only working when the DATA.MDB is NOT protected with a password !!!
Has anyone idea's how to integrate the password in above code ?

 

[tommeekers]

I'v been trying to get Aivars code to work. But so far I' ve been unsuccesfull. I presume I can call these subs in the Form_Load() of my main form, which starts up when launching my frontend ? However my program immediately says it cannot find the database, cause it is still searching for my backend at its original location.

After that initial error, it does seem to wanna run the relink code, but it errors out on the following line in the LinksDelete sub.

Dim tdf As TableDef

I thought this was just to declare the variable, how can this cause an error ?

I'm trying to make it so that the user is prompted for a new db location when the old links are not longer valid. But as a first step I'm just trying to get it to work when I specify the new location in my code, as in the example from Aivars.