Here is a sample.
Steve King
Option Compare Database 'Use database order for string comparisons
Option Explicit
Public Sub CheckAttachedTableLinks()
On Error GoTo ErrorHandler
Dim dbCurrent As Database
Dim tblDefinition As TableDef
Dim rstAction_Officers As Recordset
Dim strDATA_FileName As String
Dim strDATA_FullPathName As String
Dim strErrorMessage As String
Dim blnReattachmentProgressMeterIsActive As Boolean
Dim intTableDefIndex As Integer
Dim intUserAnswer As Integer
Dim intNumberOfTablesReattached As Integer
Dim intNumberOfTablesToBeReattached As Integer
Dim varReturnValue As Variant
Const intNONEXISTENT_TABLE As Integer = 3011
Const intPPHCDATA_NOT_FOUND As Integer = 3024
Const intACCESS_DENIED As Integer = 3051
Const intREAD_ONLY_DATABASE As Integer = 3027
intNumberOfTablesReattached = 0
blnReattachmentProgressMeterIsActive = False
strDATA_FileName = "LogGenData.MDB"
strDATA_FullPathName = strDATA_FileName
Set dbCurrent = CurrentDb()
On Error Resume Next 'This must be here
Set rstAction_Officers = dbCurrent.OpenRecordset("tblUser_Descriptions"
If Err <> 0 Then
'Error encountered in trying to access the linked table tblAction_Officers
'Notify the user and allow him/her to find the missing database file using a Browse dialog box
MsgBox Prompt:="One or more of the linked tables cannot be accessed. " _
& "Please locate the " & strDATA_FileName & " file.", _
Buttons:=vbExclamation, _
Title:=strMessage_Title
Browse (strDATA_FullPathName)
intUserAnswer = vbRetry
Do While ((strDATA_FullPathName = ""
And (intUserAnswer = vbRetry))
'User cancelled or closed the Browse dialog box without selecting a file
'Notify user that application cannot be run without finding the IOCDATA.MDB file
strErrorMessage = "You can't run the " & strMessage_Title _
& " until you locate the " & strDATA_FileName _
& " file. Choose Retry to try to find the file again;" _
& " choose Cancel to quit Microsoft Access."
intUserAnswer = MsgBox(Prompt:=strErrorMessage, _
Buttons:=vbRetryCancel, _
Title:=strMessage_Title)
If intUserAnswer = vbRetry Then
Browse (strDATA_FullPathName)
Else
'Terminate code execution, close files opened with the Open statement and clear variables.
DoCmd.Quit
End If 'If intUserAnswer = vbRetry Then
Loop 'Do While (IOCDATA_FullPathName = ""
And (UserWantsToTryAgain = True)
If strDATA_FullPathName <> "" Then
'User selected a file using the Browse dialog box
' For each table, check its connect property; if it's not connected, increment the number of
' tables to be reattached (for use with the reattachment progress meter)
intNumberOfTablesToBeReattached = 0
For intTableDefIndex = 0 To dbCurrent.TableDefs.count - 1
Set tblDefinition = dbCurrent.TableDefs(intTableDefIndex)
If tblDefinition.Connect <> "" Then
intNumberOfTablesToBeReattached = intNumberOfTablesToBeReattached + 1
End If 'If tblDefinition.Connect <> "" Then
Next intTableDefIndex 'For intTableDefIndex = 0 To dbCurrent.TableDefs.Count - 1
' Initialize the reattachment progress meter
varReturnValue = SysCmd(Action:=acSysCmdInitMeter, _
Argument2:="Attaching Tables", _
Argument3:=intNumberOfTablesToBeReattached)
blnReattachmentProgressMeterIsActive = True
' For each table, set its connect property appropriately, using the database file's full path name
' Next, refresh the table's link
intTableDefIndex = 0
Err = 0
While ((intTableDefIndex <= dbCurrent.TableDefs.count - 1) _
And _
(Err = 0))
Set tblDefinition = dbCurrent.TableDefs(intTableDefIndex)
If tblDefinition.Connect <> "" Then 'Skip base tables
tblDefinition.Connect = ";DATABASE=" & strDATA_FullPathName
Err = 0 ' If the RefreshLink operation is not successful, Err will become nonzero
tblDefinition.RefreshLink
End If 'If tblDefinition.Connect <> "" Then
If Err = 0 Then
' RefreshLink operation was successful for the current table
' Update the appropriate counters and press on
intNumberOfTablesReattached = intNumberOfTablesReattached + 1
varReturnValue = SysCmd(Action:=acSysCmdUpdateMeter, _
Argument2:=intNumberOfTablesReattached)
intTableDefIndex = intTableDefIndex + 1
End If 'If Err = 0 then
Wend 'While (TableDefIndex <= dbCurrent.TableDefs.Count - 1) And (Err = 0)
If Err <> 0 Then
'An error was encountered during the RefreshLink operation
'Notify the user with the appropriate message
If Err = intNONEXISTENT_TABLE Then
MsgBox Prompt:="The file '" & strDATA_FullPathName & "' does " _
& "not contain the table '" & tblDefinition.Name _
& "' required by the " & strMessage_Title & ".", _
Buttons:=vbCritical, _
Title:=strMessage_Title
ElseIf Err = intPPHCDATA_NOT_FOUND Then
MsgBox Prompt:="The " & strMessage_Title & " cannot be run until" _
& "the " & strDATA_FileName & " file is located.", _
Buttons:=vbCritical, _
Title:=strMessage_Title
ElseIf Err = intACCESS_DENIED Then
MsgBox Prompt:="Couldn't open " & strDATA_FullPathName _
& " because it is read-only or it is located on a " _
& "read-only share.", _
Buttons:=vbCritical, _
Title:=strMessage_Title
ElseIf Err = intREAD_ONLY_DATABASE Then
MsgBox Prompt:="Can't reattach tables because " _
& strDATA_FullPathName & " is read-only or is " _
& "located on a read-only share.", _
Buttons:=vbCritical, _
Title:=strMessage_Title
Else
MsgBox Prompt:=ERROR, _
Buttons:=vbCritical, _
Title:=strMessage_Title
End If
End 'Terminate code execution, close files opened with the Open statement
'and clear variables.
Else
' Err = 0, so all tables were successfully reattached
' Remove the reattachment progress meter from the status bar
varReturnValue = SysCmd(Action:=acSysCmdRemoveMeter)
End If 'If Err <> 0 Then (from attempt to refresh a table's link)
End If 'If IOCDATA_FullPathName <> "" then
End If 'If Err <> 0 Then (from attempt to open recordset with tblAirline_Information)
Exit Sub
ErrorHandler:
If blnReattachmentProgressMeterIsActive Then
varReturnValue = SysCmd(Action:=acSysCmdRemoveMeter)
End If 'If ReattachmentProgressMeterIsActive Then
Exit Sub
End Sub
Growth follows a healthy professional curiosity
