Hi,
I was wondering if someone could take a look at my code (Access 2000). I use it to relink backend tables on startup which works well on all my computers but I have a client running windows 2000 that reckons he has to relink everytime he uses the program ie the link is not being retained. The client is linking to a network drive if that has any bearing on things.
Startup form code:
I have a feeling its a Windows 2000 problem as it does seem to be dog from what you hear and read about it. In any case I need to fix things so this code will work on all platforms.
Thank you very kindly to all who take the time to have a look at my code
Rachael
I was wondering if someone could take a look at my code (Access 2000). I use it to relink backend tables on startup which works well on all my computers but I have a client running windows 2000 that reckons he has to relink everytime he uses the program ie the link is not being retained. The client is linking to a network drive if that has any bearing on things.
Startup form code:
Code:
Option Explicit
Option Compare Database
Private Sub Form_Open(Cancel As Integer)
On Error GoTo Err_Form_Open
Dim strTest As String, DB As DAO.Database
Dim td As DAO.TableDef
Set DB = CurrentDb
For Each td In DB.TableDefs
If Len(td.Connect) > 0 Then
On Error Resume Next
strTest = Dir(Mid(td.Connect, 11))
On Error GoTo Err_Form_Open
If Len(strTest) = 0 Then
If MsgBox("Couldn't find the data file " & Mid(td.Connect, 11) & ". Please choose the location of the data file.", vbExclamation + vbOKCancel + vbDefaultButton1, "Can't find data file") = vbOK Then
DoCmd.OpenForm "frmNewDataFile"
DoCmd.Close acForm, Me.Name
Exit Sub
Else
MsgBox "This application will now be shutdown.", vbExclamation, "Procedure Aborted"
DoCmd.Quit
End If
End If
End If
Next
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm "Splash"
Exit_Form_Open:
Exit Sub
Err_Form_Open:
MsgBox Err.Number & ":" & Error.Description
Resume Exit_Form_Open
End Sub
Relinking Module Code:
Option Explicit
Option Compare Database
Dim unProcessed As New Collection
Public Function Browse()
On Error GoTo Err_Browse
Dim strFilename As String
Dim oDialog As Object
Set oDialog = [Forms]![frmNewDataFile]!xDialog.Object
With oDialog
.DialogTitle = "Please select a new data file"
.Filter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|" & _
"*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*"
.FilterIndex = 1
.ShowOpen
If Len(.FileName) > 0 Then
[Forms]![frmNewDataFile]![txtFileName] = .FileName
End If
End With
Exit_Browse:
Exit Function
Err_Browse:
MsgBox Err.Description
Resume Exit_Browse
End Function
Public Sub AppendTables()
Dim DB As DAO.Database, X As Variant
Dim strTest As String
Set DB = CurrentDb
ClearAll
For Each X In DB.TableDefs
If Len(X.Connect) > 1 And Len(Dir(Mid(X.Connect, 11))) = 0 Then
unProcessed.Add Item:=X.Name, Key:=X.Name
End If
Next
End Sub
Public Function Processtables()
Dim strTest As String
On Err GoTo Err_BeginLink
AppendTables
strTest = Dir([Forms]![frmNewDataFile]![txtFileName])
On Error GoTo Err_BeginLink
If Len(strTest) = 0 Then
MsgBox "File Not Found. Please Try Again", vbExclamation, "Link to new data file"
Exit Function
End If
Relinktables (strTest)
DoCmd.Echo True, "Done"
MsgBox "Linking to new data file was successful"
DoCmd.Close acForm, [Forms]![frmNewDataFile].Name
Exit_BeginLink:
DoCmd.Echo True
Exit Function
Err_BeginLink:
Debug.Print Err.Number
If Err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox Err.Number & ":" & Err.Description
Resume Exit_BeginLink
End Function
Public Sub ClearAll()
Dim X
For Each X In unProcessed
unProcessed.Remove (X)
Next
End Sub
Public Function Relinktables(strFilename As String)
Dim dbbackend As DAO.Database, dblocal As DAO.Database, ws As Workspace, X, Y
Dim tdlocal As DAO.TableDef
On Error GoTo Err_Relink
Set dbbackend = DBEngine(0).OpenDatabase(strFilename)
Set dblocal = CurrentDb
For Each X In unProcessed
If Len(dblocal.TableDefs(X).Connect) > 0 Then
For Each Y In dbbackend.TableDefs
If Y.Name = X Then
Set tdlocal = dblocal.TableDefs(X)
tdlocal.Connect = ";DATABASE=" & Trim([Forms]![frmNewDataFile]![txtFileName])
tdlocal.RefreshLink
unProcessed.Remove (X)
End If
Next
End If
Next
Exit_Relink:
Exit Function
Err_Relink:
MsgBox Err.Number & ":" & Err.Description
Resume Exit_Relink
End Function
Public Sub CheckifComplete()
Dim strTest As String, Y As String, notfound As String, X
On Error GoTo Err_BeginLink
If unProcessed.Count > 0 Then
For Each X In unProcessed
notfound = notfound & X & Chr(13)
Next
Y = MsgBox("The following tables were not found in " & Chr(13) & Chr(13) & [Forms]![frmNewDataFile]!txtFileName & ":" & Chr(13) & Chr(13) & notfound & Chr(13) & "Select another database that contains the additional tables?", vbQuestion + vbYesNo, "Tables not found")
If Y = vbNo Then
Exit Sub
End If
Browse
strTest = Dir([Forms]![frmNewDataFile]![txtFileName])
If Len(strTest) = 0 Then
MsgBox "File not found. Please try again.", vbExclamation, "Link to new data file"
Exit Sub
End If
Debug.Print "Break"
Relinktables (strTest)
Else
Exit Sub
End If
CheckifComplete
Exit_BeginLink:
DoCmd.Echo True
DoCmd.Hourglass False
Exit Sub
Err_BeginLink:
Debug.Print Err.Number
If Err.Number = 457 Then
ClearAll
Resume Next
End If
MsgBox Err.Number & ":" & Err.Description
Resume Exit_BeginLink
End SubI have a feeling its a Windows 2000 problem as it does seem to be dog from what you hear and read about it. In any case I need to fix things so this code will work on all platforms.
Thank you very kindly to all who take the time to have a look at my code
Rachael
Last edited by a moderator:
