J
JK
I'm in the process of rolling out a new application I developed. It was built
using Access 2003; it's split; sitting on a network server & I'm installing
an MDE file on each users computer.
For some reason, it works fine a multiple computers but does not work on a
couple of computers. They all have Access 2003 installed.
On one computer (the most important computer) when I run the MDE file - the
application has trouble connecting to the data files. I'm using some code
from the Access inside out example - I've pasted it below.
It's also not working on another computer - but a different set of issues.
On this other computer it's jamming up, acting real slow and sluggish. It's
impossible to use.
But like I said, on most of the computers it works great. It's lighting
fast. I'm very frustrated and the powers that be want this thing implimented
ASAP.
Any help or advide you could provide would be greatly appreciated.
Below I've pasted the Load Event, the Timer Event as well as the Recconect()
function called in the Load Event.
I know this is a lot to look over - thx so much in advance.
JK
Option Compare Database
Option Explicit
Private Sub Form_Load()
Dim varReturn As Variant
Dim blRet As Boolean
Dim lngColor As Long
' Open the standard Windows
' Color Dialog Window.
lngColor = RGB(95, 95, 95) 'aDialogColor(Me.hwnd)
' If user cancel Color DIalog window request WHITE
If lngColor = -1 Then lngColor = RGB(255, 255, 255)
blRet = RestoreMDIBackGroundImage(lngColor)
On Error GoTo Splash1_Error
' Select the database window
DoCmd.SelectObject acForm, "frmSplash", True
' .. and hide it
RunCommand acCmdWindowHide
' Make sure I'm visible
Me.SetFocus
' Save the user's keyboard settings
gintEnterField = Application.GetOption("Behavior Entering Field")
gintMoveEnter = Application.GetOption("Move After Enter")
gintArrowKey = Application.GetOption("Arrow Key Behavior")
' Now, set up the application keyboard
' Following code just for demonstration - inactive in this sample
' Application.SetOption "Behavior Entering Field", 1 ' Start of field
' Application.SetOption "Move After Enter", 1 ' Move to next field
' Application.SetOption "Arrow Key Behavior", 1 ' Next character
Splash1_Exit:
Exit Sub
Splash1_Error:
MsgBox "Unexpected error during startup: " & Err & ", " & Error & vbCrLf
& vbCrLf & _
"Please report this error to your System Administrator.",
vbInformation, gstrAppTitle
ErrorLog Me.Name & "_Splash1", Err, Error
Resume Splash1_Exit
End Sub
Private Sub Form_Timer()
Dim db As DAO.Database, rst As DAO.Recordset
Dim lngAuth As Long, strDept As String, strFirst As String, strLast As
String, strAuth As String
Dim intDays As Integer
On Error GoTo Splash2_Error
' Turn off the timer
Me.TimerInterval = 0
' Check the linked tables
If ReConnect() Then
' Go on to the next step - have the user "sign on"
DoCmd.OpenForm "frmLogon"
Else
' Something went wrong
' Restore original keyboard behavior
Application.SetOption "Behavior Entering Field", gintEnterField
Application.SetOption "Move After Enter", gintMoveEnter
Application.SetOption "Arrow Key Behavior", gintArrowKey
' Put the focus back on the database window
DoCmd.SelectObject acTable, "ErrorLog", True
End If
Splash2_Exit:
' All done, close me
DoCmd.Close acForm, Me.Name
Exit Sub
Splash2_Error:
MsgBox "Unexpected error during startup: " & Err & ", " & Error & vbCrLf
& vbCrLf & _
"Please report this error to your System Administrator.",
vbInformation, gstrAppTitle
ErrorLog Me.Name & "_Splash2", Err, Error
' Put the focus back in the database window
DoCmd.SelectObject acTable, "ErrorLog", True
' and bail
Resume Splash2_Exit
End Sub
'modStartup:
Option Compare Database 'Use database order for string comparisons
Option Explicit
Public Function AttachAgain(strPath As String) As Integer
' This is a generic function that accepts a new path name
' and attempts to refresh the links of all attached tables
' Input: Path name as C:\SomeFolder\SomeSubFolder
' Output: True if successful
Dim db As DAO.Database, tdf As DAO.TableDef, rst As DAO.Recordset
Dim strFilePath As String, varRet As Variant, intFirst As Integer
Dim intI As Integer, intK As Integer, intL As Integer
' Get a pointer to the database
Set db = CurrentDb
' Initialize the full file path
strFilePath = strPath & "\\Necdc1\deptfolders\Service db\Version 3\NEC
Data Application_be.mdb"
' Set the "first table" indicator
intFirst = True
' Turn on the progress meter
varRet = SysCmd(acSysCmdInitMeter, "Reconnecting Data...",
db.TableDefs.Count)
' Set an error trap
On Error GoTo Err_Attach
' Attempt to reattach the tables
intI = 0 ' Reset the status meter counter
For Each tdf In db.TableDefs
' Looking for attached tables
If (tdf.Attributes And dbAttachedTable) Then
' Figure out if this is mdb or xls file attached
If InStr(tdf.Connect, ".mdb") <> 0 Then
' Change the Connect property to point to the new file
tdf.Connect = ";DATABASE=" & strFilePath
' Attempt to refresh the link definition
tdf.RefreshLink
' If the first table, then open a recordset
' to make this go faster
If (intFirst = True) Then
Set rst = db.OpenRecordset(tdf.Name)
intFirst = False
End If
ElseIf InStr(tdf.Connect, ".xls") <> 0 Then
' One of the Excel attached files - find the DATABASE part
intK = InStr(tdf.Connect, ";DATABASE=")
' Make sure we found it
If intK <> 0 Then
' Now find the file name
intL = InStrRev(tdf.Connect, "\")
' Make sure we found it
If intL <> 0 Then
' Fix the Connect property
tdf.Connect = Left(tdf.Connect, intK + 9) & strPath
& _
Mid(tdf.Connect, intL)
' Attempt to refresh
tdf.RefreshLink
End If
End If
End If
End If
' Update the status counter
intI = intI + 1
' .. and update the progress meter
varRet = SysCmd(acSysCmdUpdateMeter, intI)
' And pause for a sec so the status bar updates
DoEvents
Next tdf
' Done - clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Clear the object variables
Set tdf = Nothing
rst.Close
Set rst = Nothing
Set db = Nothing
' Return attach successful
AttachAgain = True
Attach_Exit:
Exit Function
Err_Attach:
' Uh, oh - failed. Write a log record
ErrorLog "AttachAgain " & strPath, Err, Error
' Clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Clear the object variables
Set tdf = Nothing
Set db = Nothing
' Return attach failed
AttachAgain = False
' Exit
Resume Attach_Exit
End Function
Public Function CheckConnect() As Integer
' This function is called by frmCopyright after it verifies
' that all library references are OK.
Dim db As DAO.Database, rst As DAO.Recordset, tdf As DAO.TableDef
Dim strFilePath As String, strPath As String
Dim fdgO As FileDialog, varSel As Variant
' Do a test open of a linked table inside an error trap
On Error Resume Next
Set db = CurrentDb
Set rst = db.OpenRecordset("tblContacts", dbOpenDynaset)
' If no error, then close and return true
If Err = 0 Then
rst.Close
' Clear the objects
Set rst = Nothing
Set db = Nothing
' Set OK return
CheckConnect = True
' Done
Exit Function
End If
' Clear the objects
Set rst = Nothing
Set db = Nothing
' Ooops. Got an error - clear it
Err.Clear
' Set a generic error trap from here on
On Error GoTo Attach_Err
' First, try to use the current path of this database
strPath = CurrentProject.path
strFilePath = strPath & "\\Necdc1\deptfolders\Service db\Version 3\NEC
Data Application_be.mdb"
' Use DIR to see if the data file is here
If Not IsNothing(Dir(strFilePath)) Then
' Call the generic re-attach code
If AttachAgain(strPath) = -1 Then
' Got a good re-attach
' Set OK return
CheckConnect = True
' Done
Exit Function
End If
End If
' No success to this point
' Data file not found in application folder - try to ask the user
MsgBox "The table links for this sample application are not correct, " & _
"and the data file could not be found in the expected default
folder: " & _
strPath & ". Please locate the folder containing the sample data in
the following " & _
"dialog.", vbInformation, gstrAppTitle
' Create a file dialog object pointer
Set fdgO = Application.FileDialog(msoFileDialogFilePicker)
With fdgO
' Select only one folder
.AllowMultiSelect = False
' Set the dialog title
.Title = "Locate Folder Containing Sample Data"
' Set the button caption
.ButtonName = "Choose"
' Make sure the filter list is clear
.Filters.Clear
' Add one filter
.Filters.Add "All Files", "*.*", 1
' Set the filter index to 1
.FilterIndex = 1
' Set the initial file name
.InitialFileName = strPath
' Show file details
.InitialView = msoFileDialogViewDetails
' Show the dialog and test the return
If .Show = 0 Then
MsgBox "You failed to select the correct file. WARNING: " & _
"You may not be able to open any of the linked tables or run
the " & _
"application. You can re-open this form (frmCopyright) or "
& _
"the startup form (frmStartup) to try again.", vbCritical,
gstrAppTitle
' Set Failed return
CheckConnect = False
' Done
Exit Function
End If
' Should be only one path name - grab it
strFilePath = .SelectedItems(1)
End With
' Get just the path
strPath = Left(strFilePath, InStrRev(strFilePath, "\") - 1)
' Call the common re-attach
varSel = AttachAgain(strPath)
' Do one final check
If varSel = 0 Then
MsgBox "Relinking of attached tables failed. " & _
vbCrLf & vbCrLf & "You can try to open the application again.", _
vbCritical, "New England Coffee Company"
' Close and bail
CheckConnect = False
Exit Function
End If
' All OK
CheckConnect = True
Attach_Exit:
Exit Function
Attach_Err:
' Got an unexpected error
' Log it
ErrorLog "CheckConnect", Err, Error
' Tell user-
MsgBox "Unexpected error checking attached tables. " & Err & ", " &
Error, vbCritical
' Bail
CheckConnect = False
Resume Attach_Exit
End Function
Public Function CheckVersion(curVNo As Currency) As Integer
' Software vs data file version checker
' Input: version number from the attached data file
' Return: True if this software version is compatible
' Check the integer portion of both versions
' This allows minor update revisions to the code (v1.1, v1.2) that
' will still work with "base" version of the data and vice-versa.
If Int(curVNo) <> Int(gTHISVERSION) Then
' Base versions not equal - display appropriate error and bail
If curVNo < gTHISVERSION Then
MsgBox "The version of this application code is later than your
data tables. " & _
"Contact your system administrator for the special procedure
to upgrade your data tables to work with this code.", _
vbCritical, "System Administrator"
Else
MsgBox "The version of this application code is earlier than
your data tables. " & _
"Contact your system administrator for a more up-to-date
version of the code.", vbCritical, _
"System Administrator"
End If
CheckVersion = False
Else
CheckVersion = True
End If
End Function
Public Function ReConnect()
Dim db As DAO.Database, tdf As DAO.TableDef, rst As DAO.Recordset, rstV As
DAO.Recordset
Dim strFile As String, varRet As Variant, frm As Form, strPath As String,
intI As Integer
' This is a slightly different version of reconnect code
' Called by frmSplash - the normal startup form for this application
On Error Resume Next
Set db = CurrentDb
' Turn on the hourglass - this may take a few secs.
DoCmd.Hourglass True
' First, check linked table version
Set rstV = db.OpenRecordset("ztblVersion")
' Got a failure - so try to reattach the tables
If Err <> 0 Then GoTo Reattach
' Make sure we're on the first row
rstV.MoveFirst
' Call the version checker
If Not CheckVersion(rstV!Version) Then
' Tell caller that "reconnect" failed
ReConnect = False
' Close the version recordset
rstV.Close
' Clear the objects
Set rstV = Nothing
Set db = Nothing
' Done
DoCmd.Hourglass False
Exit Function
End If
' Versions match - now verify all the other tables
' NOTE: We're leaving rstV open at this point for better efficiency
' in a shared database environment. JET will share the already
established thread.
' Turn on the progress meter on the status bar
varRet = SysCmd(acSysCmdInitMeter, "Verifying data tables...",
db.TableDefs.Count)
' Loop through all TableDefs
For Each tdf In db.TableDefs
' Looking for attached tables
If (tdf.Attributes And dbAttachedTable) Then
' Try to open the table
Set rst = tdf.OpenRecordset()
' If got an error - then try to relink
If Err <> 0 Then GoTo Reattach
' This one OK - close it
rst.Close
' And clear the object
Set rst = Nothing
End If
' Update the progress counter
intI = intI + 1
varRet = SysCmd(acSysCmdUpdateMeter, intI)
Next tdf
' Got through them all - clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Turn off the hourglass
DoCmd.Hourglass False
' Set a good return
ReConnect = True
' Edit the Version table
rstV.Edit
' Update the open count - we check this on exit to recommend a backup
rstV!OpenCount = rstV!OpenCount + 1
' Update the row
rstV.Update
' Close and clear the objects
rstV.Close
Set rstV = Nothing
Set db = Nothing
' DONE!
Exit Function
Reattach:
' Clear the current error
Err.Clear
' Set a new error trap
On Error GoTo BadReconnect
' Turn off the hourglass for now
DoCmd.Hourglass False
' .. and clear the status bar
varRet = SysCmd(acSysCmdClearStatus)
' Tell the user about the problem - about to show an open file dialog
MsgBox "There's a temporary problem connecting to the data tables.
Please locate the data file in the following dialog.", vbInformation, "System
Administrator"
' Establish a new ComDlg object
With New ComDlg
' Set the title of the dialog
.DialogTitle = "Locate Data Files"
' Set the default file name
.FileName = "NEC Data Application_be.mdb"
' .. and start directory
.Directory = CurrentProject.path
' .. and file extension
.Extension = "mdb"
' .. but show all mdb files just in case
.Filter = "File (*.mdb)|*.mdb"
' Default directory is where this file is located
.Directory = CurrentProject.path
' Tell the common dialog that the file and path must exist
.ExistFlags = FileMustExist + PathMustExist
If .ShowOpen Then
strFile = .FileName
Else
Err.Raise 3999
End If
End With
' Open the "info" form telling what we're doing
DoCmd.OpenForm "frmReconnect"
' .. and be sure it has the focus
Forms!frmReconnect.SetFocus
' Attempt to re-attach the Version table first and check it
Set tdf = db.TableDefs("ztblVersion")
tdf.Connect = ";DATABASE=" & strFile
tdf.RefreshLink
' OK, now check linked table version
Set rst = db.OpenRecordset("ztblVersion")
rst.MoveFirst
' Call the version checker
If Not CheckVersion(rst!Version) Then
' Tell the caller that we failed
ReConnect = False
' Close the version recordset
rst.Close
' .. and clear the object
Set rst = Nothing
' Bail
Exit Function
End If
' Passed version check - edit the version record
rst.Edit
' Update the open count - we check this on exit to recommend a backup
rst!OpenCount = rst!OpenCount + 1
' Write it back
rst.Update
' Close the recordset
rst.Close
' .. and clear the object
Set rst = Nothing
' Now, reattach the other tables
' Strip out just the path name
strPath = Left(strFile, InStrRev(strFile, "\") - 1)
' Call the generic re-attach function
If AttachAgain(strPath) = 0 Then
' Oops - failed. Raise an error
Err.Raise 3999
End If
' Close the information form
DoCmd.Close acForm, "frmReconnect"
' Clear the db object
Set db = Nothing
' Return a positive result
ReConnect = True
' .. and exit
Connect_Exit:
Exit Function
BadReconnect:
' Ooops
MsgBox "Reconnect to data failed.", vbCritical, "System Administrator"
' Indicate failure
ReConnect = False
' Close the info form if it is open
If IsFormLoaded("frmReconnect") Then DoCmd.Close acForm, "frmReconnect"
' Clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' .. and bail
Resume Connect_Exit
End Function
using Access 2003; it's split; sitting on a network server & I'm installing
an MDE file on each users computer.
For some reason, it works fine a multiple computers but does not work on a
couple of computers. They all have Access 2003 installed.
On one computer (the most important computer) when I run the MDE file - the
application has trouble connecting to the data files. I'm using some code
from the Access inside out example - I've pasted it below.
It's also not working on another computer - but a different set of issues.
On this other computer it's jamming up, acting real slow and sluggish. It's
impossible to use.
But like I said, on most of the computers it works great. It's lighting
fast. I'm very frustrated and the powers that be want this thing implimented
ASAP.
Any help or advide you could provide would be greatly appreciated.
Below I've pasted the Load Event, the Timer Event as well as the Recconect()
function called in the Load Event.
I know this is a lot to look over - thx so much in advance.
JK
Option Compare Database
Option Explicit
Private Sub Form_Load()
Dim varReturn As Variant
Dim blRet As Boolean
Dim lngColor As Long
' Open the standard Windows
' Color Dialog Window.
lngColor = RGB(95, 95, 95) 'aDialogColor(Me.hwnd)
' If user cancel Color DIalog window request WHITE
If lngColor = -1 Then lngColor = RGB(255, 255, 255)
blRet = RestoreMDIBackGroundImage(lngColor)
On Error GoTo Splash1_Error
' Select the database window
DoCmd.SelectObject acForm, "frmSplash", True
' .. and hide it
RunCommand acCmdWindowHide
' Make sure I'm visible
Me.SetFocus
' Save the user's keyboard settings
gintEnterField = Application.GetOption("Behavior Entering Field")
gintMoveEnter = Application.GetOption("Move After Enter")
gintArrowKey = Application.GetOption("Arrow Key Behavior")
' Now, set up the application keyboard
' Following code just for demonstration - inactive in this sample
' Application.SetOption "Behavior Entering Field", 1 ' Start of field
' Application.SetOption "Move After Enter", 1 ' Move to next field
' Application.SetOption "Arrow Key Behavior", 1 ' Next character
Splash1_Exit:
Exit Sub
Splash1_Error:
MsgBox "Unexpected error during startup: " & Err & ", " & Error & vbCrLf
& vbCrLf & _
"Please report this error to your System Administrator.",
vbInformation, gstrAppTitle
ErrorLog Me.Name & "_Splash1", Err, Error
Resume Splash1_Exit
End Sub
Private Sub Form_Timer()
Dim db As DAO.Database, rst As DAO.Recordset
Dim lngAuth As Long, strDept As String, strFirst As String, strLast As
String, strAuth As String
Dim intDays As Integer
On Error GoTo Splash2_Error
' Turn off the timer
Me.TimerInterval = 0
' Check the linked tables
If ReConnect() Then
' Go on to the next step - have the user "sign on"
DoCmd.OpenForm "frmLogon"
Else
' Something went wrong
' Restore original keyboard behavior
Application.SetOption "Behavior Entering Field", gintEnterField
Application.SetOption "Move After Enter", gintMoveEnter
Application.SetOption "Arrow Key Behavior", gintArrowKey
' Put the focus back on the database window
DoCmd.SelectObject acTable, "ErrorLog", True
End If
Splash2_Exit:
' All done, close me
DoCmd.Close acForm, Me.Name
Exit Sub
Splash2_Error:
MsgBox "Unexpected error during startup: " & Err & ", " & Error & vbCrLf
& vbCrLf & _
"Please report this error to your System Administrator.",
vbInformation, gstrAppTitle
ErrorLog Me.Name & "_Splash2", Err, Error
' Put the focus back in the database window
DoCmd.SelectObject acTable, "ErrorLog", True
' and bail
Resume Splash2_Exit
End Sub
'modStartup:
Option Compare Database 'Use database order for string comparisons
Option Explicit
Public Function AttachAgain(strPath As String) As Integer
' This is a generic function that accepts a new path name
' and attempts to refresh the links of all attached tables
' Input: Path name as C:\SomeFolder\SomeSubFolder
' Output: True if successful
Dim db As DAO.Database, tdf As DAO.TableDef, rst As DAO.Recordset
Dim strFilePath As String, varRet As Variant, intFirst As Integer
Dim intI As Integer, intK As Integer, intL As Integer
' Get a pointer to the database
Set db = CurrentDb
' Initialize the full file path
strFilePath = strPath & "\\Necdc1\deptfolders\Service db\Version 3\NEC
Data Application_be.mdb"
' Set the "first table" indicator
intFirst = True
' Turn on the progress meter
varRet = SysCmd(acSysCmdInitMeter, "Reconnecting Data...",
db.TableDefs.Count)
' Set an error trap
On Error GoTo Err_Attach
' Attempt to reattach the tables
intI = 0 ' Reset the status meter counter
For Each tdf In db.TableDefs
' Looking for attached tables
If (tdf.Attributes And dbAttachedTable) Then
' Figure out if this is mdb or xls file attached
If InStr(tdf.Connect, ".mdb") <> 0 Then
' Change the Connect property to point to the new file
tdf.Connect = ";DATABASE=" & strFilePath
' Attempt to refresh the link definition
tdf.RefreshLink
' If the first table, then open a recordset
' to make this go faster
If (intFirst = True) Then
Set rst = db.OpenRecordset(tdf.Name)
intFirst = False
End If
ElseIf InStr(tdf.Connect, ".xls") <> 0 Then
' One of the Excel attached files - find the DATABASE part
intK = InStr(tdf.Connect, ";DATABASE=")
' Make sure we found it
If intK <> 0 Then
' Now find the file name
intL = InStrRev(tdf.Connect, "\")
' Make sure we found it
If intL <> 0 Then
' Fix the Connect property
tdf.Connect = Left(tdf.Connect, intK + 9) & strPath
& _
Mid(tdf.Connect, intL)
' Attempt to refresh
tdf.RefreshLink
End If
End If
End If
End If
' Update the status counter
intI = intI + 1
' .. and update the progress meter
varRet = SysCmd(acSysCmdUpdateMeter, intI)
' And pause for a sec so the status bar updates
DoEvents
Next tdf
' Done - clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Clear the object variables
Set tdf = Nothing
rst.Close
Set rst = Nothing
Set db = Nothing
' Return attach successful
AttachAgain = True
Attach_Exit:
Exit Function
Err_Attach:
' Uh, oh - failed. Write a log record
ErrorLog "AttachAgain " & strPath, Err, Error
' Clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Clear the object variables
Set tdf = Nothing
Set db = Nothing
' Return attach failed
AttachAgain = False
' Exit
Resume Attach_Exit
End Function
Public Function CheckConnect() As Integer
' This function is called by frmCopyright after it verifies
' that all library references are OK.
Dim db As DAO.Database, rst As DAO.Recordset, tdf As DAO.TableDef
Dim strFilePath As String, strPath As String
Dim fdgO As FileDialog, varSel As Variant
' Do a test open of a linked table inside an error trap
On Error Resume Next
Set db = CurrentDb
Set rst = db.OpenRecordset("tblContacts", dbOpenDynaset)
' If no error, then close and return true
If Err = 0 Then
rst.Close
' Clear the objects
Set rst = Nothing
Set db = Nothing
' Set OK return
CheckConnect = True
' Done
Exit Function
End If
' Clear the objects
Set rst = Nothing
Set db = Nothing
' Ooops. Got an error - clear it
Err.Clear
' Set a generic error trap from here on
On Error GoTo Attach_Err
' First, try to use the current path of this database
strPath = CurrentProject.path
strFilePath = strPath & "\\Necdc1\deptfolders\Service db\Version 3\NEC
Data Application_be.mdb"
' Use DIR to see if the data file is here
If Not IsNothing(Dir(strFilePath)) Then
' Call the generic re-attach code
If AttachAgain(strPath) = -1 Then
' Got a good re-attach
' Set OK return
CheckConnect = True
' Done
Exit Function
End If
End If
' No success to this point
' Data file not found in application folder - try to ask the user
MsgBox "The table links for this sample application are not correct, " & _
"and the data file could not be found in the expected default
folder: " & _
strPath & ". Please locate the folder containing the sample data in
the following " & _
"dialog.", vbInformation, gstrAppTitle
' Create a file dialog object pointer
Set fdgO = Application.FileDialog(msoFileDialogFilePicker)
With fdgO
' Select only one folder
.AllowMultiSelect = False
' Set the dialog title
.Title = "Locate Folder Containing Sample Data"
' Set the button caption
.ButtonName = "Choose"
' Make sure the filter list is clear
.Filters.Clear
' Add one filter
.Filters.Add "All Files", "*.*", 1
' Set the filter index to 1
.FilterIndex = 1
' Set the initial file name
.InitialFileName = strPath
' Show file details
.InitialView = msoFileDialogViewDetails
' Show the dialog and test the return
If .Show = 0 Then
MsgBox "You failed to select the correct file. WARNING: " & _
"You may not be able to open any of the linked tables or run
the " & _
"application. You can re-open this form (frmCopyright) or "
& _
"the startup form (frmStartup) to try again.", vbCritical,
gstrAppTitle
' Set Failed return
CheckConnect = False
' Done
Exit Function
End If
' Should be only one path name - grab it
strFilePath = .SelectedItems(1)
End With
' Get just the path
strPath = Left(strFilePath, InStrRev(strFilePath, "\") - 1)
' Call the common re-attach
varSel = AttachAgain(strPath)
' Do one final check
If varSel = 0 Then
MsgBox "Relinking of attached tables failed. " & _
vbCrLf & vbCrLf & "You can try to open the application again.", _
vbCritical, "New England Coffee Company"
' Close and bail
CheckConnect = False
Exit Function
End If
' All OK
CheckConnect = True
Attach_Exit:
Exit Function
Attach_Err:
' Got an unexpected error
' Log it
ErrorLog "CheckConnect", Err, Error
' Tell user-
MsgBox "Unexpected error checking attached tables. " & Err & ", " &
Error, vbCritical
' Bail
CheckConnect = False
Resume Attach_Exit
End Function
Public Function CheckVersion(curVNo As Currency) As Integer
' Software vs data file version checker
' Input: version number from the attached data file
' Return: True if this software version is compatible
' Check the integer portion of both versions
' This allows minor update revisions to the code (v1.1, v1.2) that
' will still work with "base" version of the data and vice-versa.
If Int(curVNo) <> Int(gTHISVERSION) Then
' Base versions not equal - display appropriate error and bail
If curVNo < gTHISVERSION Then
MsgBox "The version of this application code is later than your
data tables. " & _
"Contact your system administrator for the special procedure
to upgrade your data tables to work with this code.", _
vbCritical, "System Administrator"
Else
MsgBox "The version of this application code is earlier than
your data tables. " & _
"Contact your system administrator for a more up-to-date
version of the code.", vbCritical, _
"System Administrator"
End If
CheckVersion = False
Else
CheckVersion = True
End If
End Function
Public Function ReConnect()
Dim db As DAO.Database, tdf As DAO.TableDef, rst As DAO.Recordset, rstV As
DAO.Recordset
Dim strFile As String, varRet As Variant, frm As Form, strPath As String,
intI As Integer
' This is a slightly different version of reconnect code
' Called by frmSplash - the normal startup form for this application
On Error Resume Next
Set db = CurrentDb
' Turn on the hourglass - this may take a few secs.
DoCmd.Hourglass True
' First, check linked table version
Set rstV = db.OpenRecordset("ztblVersion")
' Got a failure - so try to reattach the tables
If Err <> 0 Then GoTo Reattach
' Make sure we're on the first row
rstV.MoveFirst
' Call the version checker
If Not CheckVersion(rstV!Version) Then
' Tell caller that "reconnect" failed
ReConnect = False
' Close the version recordset
rstV.Close
' Clear the objects
Set rstV = Nothing
Set db = Nothing
' Done
DoCmd.Hourglass False
Exit Function
End If
' Versions match - now verify all the other tables
' NOTE: We're leaving rstV open at this point for better efficiency
' in a shared database environment. JET will share the already
established thread.
' Turn on the progress meter on the status bar
varRet = SysCmd(acSysCmdInitMeter, "Verifying data tables...",
db.TableDefs.Count)
' Loop through all TableDefs
For Each tdf In db.TableDefs
' Looking for attached tables
If (tdf.Attributes And dbAttachedTable) Then
' Try to open the table
Set rst = tdf.OpenRecordset()
' If got an error - then try to relink
If Err <> 0 Then GoTo Reattach
' This one OK - close it
rst.Close
' And clear the object
Set rst = Nothing
End If
' Update the progress counter
intI = intI + 1
varRet = SysCmd(acSysCmdUpdateMeter, intI)
Next tdf
' Got through them all - clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Turn off the hourglass
DoCmd.Hourglass False
' Set a good return
ReConnect = True
' Edit the Version table
rstV.Edit
' Update the open count - we check this on exit to recommend a backup
rstV!OpenCount = rstV!OpenCount + 1
' Update the row
rstV.Update
' Close and clear the objects
rstV.Close
Set rstV = Nothing
Set db = Nothing
' DONE!
Exit Function
Reattach:
' Clear the current error
Err.Clear
' Set a new error trap
On Error GoTo BadReconnect
' Turn off the hourglass for now
DoCmd.Hourglass False
' .. and clear the status bar
varRet = SysCmd(acSysCmdClearStatus)
' Tell the user about the problem - about to show an open file dialog
MsgBox "There's a temporary problem connecting to the data tables.
Please locate the data file in the following dialog.", vbInformation, "System
Administrator"
' Establish a new ComDlg object
With New ComDlg
' Set the title of the dialog
.DialogTitle = "Locate Data Files"
' Set the default file name
.FileName = "NEC Data Application_be.mdb"
' .. and start directory
.Directory = CurrentProject.path
' .. and file extension
.Extension = "mdb"
' .. but show all mdb files just in case
.Filter = "File (*.mdb)|*.mdb"
' Default directory is where this file is located
.Directory = CurrentProject.path
' Tell the common dialog that the file and path must exist
.ExistFlags = FileMustExist + PathMustExist
If .ShowOpen Then
strFile = .FileName
Else
Err.Raise 3999
End If
End With
' Open the "info" form telling what we're doing
DoCmd.OpenForm "frmReconnect"
' .. and be sure it has the focus
Forms!frmReconnect.SetFocus
' Attempt to re-attach the Version table first and check it
Set tdf = db.TableDefs("ztblVersion")
tdf.Connect = ";DATABASE=" & strFile
tdf.RefreshLink
' OK, now check linked table version
Set rst = db.OpenRecordset("ztblVersion")
rst.MoveFirst
' Call the version checker
If Not CheckVersion(rst!Version) Then
' Tell the caller that we failed
ReConnect = False
' Close the version recordset
rst.Close
' .. and clear the object
Set rst = Nothing
' Bail
Exit Function
End If
' Passed version check - edit the version record
rst.Edit
' Update the open count - we check this on exit to recommend a backup
rst!OpenCount = rst!OpenCount + 1
' Write it back
rst.Update
' Close the recordset
rst.Close
' .. and clear the object
Set rst = Nothing
' Now, reattach the other tables
' Strip out just the path name
strPath = Left(strFile, InStrRev(strFile, "\") - 1)
' Call the generic re-attach function
If AttachAgain(strPath) = 0 Then
' Oops - failed. Raise an error
Err.Raise 3999
End If
' Close the information form
DoCmd.Close acForm, "frmReconnect"
' Clear the db object
Set db = Nothing
' Return a positive result
ReConnect = True
' .. and exit
Connect_Exit:
Exit Function
BadReconnect:
' Ooops
MsgBox "Reconnect to data failed.", vbCritical, "System Administrator"
' Indicate failure
ReConnect = False
' Close the info form if it is open
If IsFormLoaded("frmReconnect") Then DoCmd.Close acForm, "frmReconnect"
' Clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' .. and bail
Resume Connect_Exit
End Function