Per Veli Izzet:
It started to ask for all the tables, one by one. Is there no easy way
for that?
If you spend some time digging through this rat's nest, it won't look so bad.
Also, for a single back end, a lot of the code can be deleted.
I use something like this in all of my apps.
Usually I drive it from a custom .INI file, but sometimes from a Common File
dialog.
Takes no more than fifteen minutes to customize it to a given application.
Most of that time is spent copying/pasting connection names into the
front-end-resident table "zstblAttachmentNames" - which drives the code by
telling it what tables need reconnecting and which back end they need to connect
to.
----------------------------
Option Compare Database 'Use database order for string comparisons
Option Explicit
' Next available line# series = 4000
Const mModuleName = "basConnectRefresh"
Const mConnectionFatal = 0
Const mTestTableHasValidConnection = -1
Const mConnectionNeedsRefresh = -2
Public Function ConnectRefresh_Main(ByVal theDbPath As String, ByVal
theSampleTableName As String) As Boolean
1000 DebugStackPush mModuleName & ": ConnectRefresh_Main"
1001 On Error GoTo ConnectRefresh_Main_err
' PURPOSE: To reconnect all tables names in zstblAttachmentInfo
' ACCEPTS: - DOS path to the back end where tables should be found
' - Name of a table to check to see if it really exists in the
supplied DB path
' RETURNS: True/False depending on success
1010 Dim pathDbMain As String
Dim gotFatal As Integer
Dim myResult As Integer
1015 DoCmd.Hourglass True
1020 StatusSet "Checking 'Main' connections..."
1021 pathDbMain = theDbPath
1022 If Len(pathDbMain) = 0 Then
1023 gotFatal = True
1024 Else
1025 myResult = validateConnection("mainDataBaseName", pathDbMain,
theSampleTableName)
1100 Select Case myResult
Case mConnectionFatal
1120 gotFatal = True
1130 Case mTestTableHasValidConnection
1131 gotFatal = Not refreshConnections("Main", pathDbMain)
1140 Case mConnectionNeedsRefresh
1141 gotFatal = Not refreshConnections("Main", pathDbMain)
1039 End Select
1040 End If
1990 If gotFatal = False Then
1991 ConnectRefresh_Main = True
1992 End If
1997 StatusSet ""
1998 DoCmd.Hourglass False
1999 DebugStackPop
ConnectRefresh_Main_xit:
StatusSet ""
DebugStackPop
On Error Resume Next
Exit Function
ConnectRefresh_Main_err:
BugAlert True, ""
Resume ConnectRefresh_Main_xit
End Function
Function ConnectRefresh_Budget(ByVal theDbPath As String) As Integer
DebugStackPush mModuleName & ": ConnectRefresh_Budget"
On Error GoTo ConnectRefresh_Budget_err
' PURPOSE: To refresh connectins to tblBudget... tables
' ACCEPTS: Path to the Budget DB
' RETURNS: True/False depending on success
'
' NOTES: 1) The budget DB is deleted and re-created each time budget
' info is imported. It is the calling routine's responsibility
' to endure that the DB exists.
ConnectRefresh_Budget = refreshConnections("Budget", theDbPath)
ConnectRefresh_Budget_xit:
DebugStackPop
On Error Resume Next
Exit Function
ConnectRefresh_Budget_err:
BugAlert True, ""
Resume ConnectRefresh_Budget_xit
End Function
Public Function refreshConnections(theDbType As String, theDbPath As String) As
Boolean
3000 DebugStackPush mModuleName & ": refreshConnections"
3001 On Error GoTo refreshConnections_err
' PURPOSE: To refresh all connections of a given DB type
' ACCEPTS: - DB type
' - Path to which tables in questin SB connected
' RETURNS: True/False depending on success
3020 Dim thisDB As Database
Dim myRS As Recordset
Dim myQuery As QueryDef
Dim myTD As TableDef
Dim i As Integer
Dim connectCount As Integer
Dim curTableName As String
3030 Set thisDB = DBEngine(0)(0)
3031 Set myQuery = thisDB.QueryDefs("qryRefreshConnections")
3032 myQuery.Parameters("theDbType") = theDbType
3033 Set myRS = myQuery.OpenRecordset(DB_OPEN_DYNASET)
3035 If myRS.BOF And myRS.EOF Then
3036 BugAlert True, "No records found for DB type '" & theDbType & "'."
3037 Else
'logTime True, "Begin reconnecting tables"
3050 StatusSet "Checking table connections..."
3060 myRS.MoveFirst
3070 Do Until myRS.EOF
3071 curTableName = myRS!TableName
3072 Set myTD = thisDB.TableDefs(curTableName)
3080 If myTD.Connect <> ";Database=" & theDbPath Then
3081 StatusSet "Re-Connecting " & curTableName
3082 myRS.Edit
3083 myRS!oldConnect = myTD.Connect
3084 myRS.Update
3085 connectCount = connectCount + 1
3086 myTD.Connect = ";Database=" & theDbPath
3087 myTD.RefreshLink
3099 End If
'logTime False, curTableName
3100 myRS.MoveNext
3300 Loop
3997 refreshConnections = True
3998 StatusSet ""
'logTime False, "End reconnecting tables"
3999 End If
refreshConnections_xit:
DebugStackPop
On Error Resume Next
Set myTD = Nothing
Set myQuery = Nothing
myRS.Close
Set myRS = Nothing
Set thisDB = Nothing
Exit Function
refreshConnections_err:
If connectCount > 0 Then
myRS.MoveFirst 'If we had a problem, try to restore original
connections.,,
For i = 1 To connectCount
Set myTD = thisDB.TableDefs(myRS!TableName)
myTD.Connect = myRS!oldConnect
myTD.RefreshLink
myRS.MoveNext
Next i
End If
BugAlert True, "CurTableName = '" & curTableName & "'."
Resume refreshConnections_xit
End Function
Private Function validateConnection(ByVal theParameterName As String, ByVal
theDbPath As String, ByVal theTestTable As String) As Integer
2000 DebugStackPush mModuleName & ": validateConnection"
2001 On Error GoTo validateConnection_err
' Performs a 3-phase check on the DB/Table in question:
' 1) Checks to see if DB exists and can be opened as a MS Access DB
' 2) Checks to see if theTestTable can be opened in the DB
' 3) Checks the connection string for theTestTable to see if it matches
theDbPath
2010 Dim thisWS As Workspace
Dim thisDB As Database
Dim remoteDB As Database
Dim myRS As Recordset
Dim myTD As TableDef
Const invalidPath = 3044
Const cannotOpenDB = 3049
Const cannotFindFile = 3024
Const objectNotFound = 3011
2020 Set thisWS = DBEngine(0)
2040 Set thisDB = DBEngine(0)(0)
On Error Resume Next
Set remoteDB = thisWS.OpenDatabase(theDbPath)
If Err > 0 Then
MsgBox "'" & theDbPath & "' " & " was not found or is not a MS Access
database." & vbCrLf & vbCrLf & "Application cannot be run.", vbCritical, "Fatal
Error"
Else
Set myRS = remoteDB.OpenRecordset(theTestTable, dbOpenTable)
If Err > 0 Then
MsgBox "Table '" & theTestTable & "' not found in " & theDbPath &
"'." & vbCrLf & vbCrLf & "Application cannot be run.", vbCritical, "Fatal Error"
Else
2120 On Error GoTo validateConnection_err
2130 Set myTD = thisDB.TableDefs(theTestTable)
2140 If myTD.Connect = ";Database=" & theDbPath Then
2150 validateConnection = mTestTableHasValidConnection
2160 Else
2170 validateConnection = mConnectionNeedsRefresh
2180 End If
2190 End If
2999 End If
validateConnection_xit:
DebugStackPop
On Error Resume Next
Set myTD = Nothing
myRS.Close
Set myRS = Nothing
thisDB.Close
Set thisDB = Nothing
Set thisWS = Nothing
Exit Function
validateConnection_err:
BugAlert True, ""
Resume validateConnection_xit
End Function
Public Function tryLink(ByVal theLinkName As String) As Boolean
DebugStackPush mModuleName & ": tryLink"
On Error GoTo tryLink_err
' PURPOSE: To see whether-or-not a given link is still good
' ACCEPTS: Name of the link in question
' RETURNS: True/False depending on success
'
' NOTES: 1) If we can't find the first field in the linked table,
' the link must be NG.
Dim myFieldName As String
On Error Resume Next
myFieldName = CurrentDb.TableDefs(theLinkName).Fields(0).Name
If Err = 0 Then
tryLink = True
End If
On Error GoTo tryLink_err
tryLink_xit:
DebugStackPop
On Error Resume Next
Exit Function
tryLink_err:
BugAlert True, ""
Resume tryLink_xit
End Function
Option Compare Database 'Use database order for string comparisons
Option Explicit
' This module contains the routines used to trap/log errors and
' show the "bugAlert" screen. It is derived from my "real" bugAlert module,
' but stripped down to the bare essentials to the end of placating any code that
' calls the bugAlert routines (namely debugStackPush(), debugStackPop, and
bugAlert().
' Every procedure should have the following boilerplate in it to implement
' error trapping. What I do is create a .txt file with that boilerplate
' in it, with the single quotes removed. Then I just copy/paste from the
' .txt file each time I starting writing a routine. After pasting in the
' boilerplate, I just do a rename of "xxx" to the procedure name.
' Pete Cresswell
' 3/3/2003
' -----------------------------------------
' debugStackPush Me.Name & ": xxx"
' On Error GoTo xxx_err
'' PURPOSE: To
'xxx_xit:
' debugStackPop
' On Error Resume Next
' Exit Sub
'
'xxx_err:
' bugAlert True, ""
' Resume xxx_xit
' -----------------------------------------
Const mModuleName = "basBugAlert_Lite"
Const mDebugStackTotalSize = 52
Global gDebugStack(mDebugStackTotalSize)
Global Const gStackLimit = 50
Global gStackPointer As Integer
Sub bugAlert(ByVal theDisplaySwitch As Integer, ByVal theSupplementalMessage As
String)
' PURPOSE: To show information about the trapped error
' ACCEPTS: - A switch that the "real" version of bugAlert uses to decide how
large and detailed
' a screen to show
' - Optional message text that the calling routine might want to supply
for
' display with the error message
'
' NOTES: 1) The "real" version logs the error in a text file.
Dim myErrorLine As Long
Dim myErrorNumber As Long
Dim myErrorMessage As String
Dim myErrorLocation As String
myErrorLine = Erl 'Capture relevant info ASAP. Dunno why, but
intuitively it seems like a good idea.
myErrorNumber = Err
myErrorMessage = Error$
myErrorLocation = gDebugStack(gStackPointer)
MsgBox myErrorLocation & ", Line " & Format$(myErrorLine, "000000") & " " &
Format$(myErrorNumber, "0000") & ": " & myErrorMessage & vbCrLf &
theSupplementalMessage, vbCritical, "There's Trouble In River City!"
End Sub
Sub debugStackPop()
On Error GoTo debugStackPop_err
' PURPOSE: To pop the last procedure name off the top of the debug stack
Dim i As Integer
If gStackPointer <= gStackLimit Then
gDebugStack(gStackPointer) = ""
End If
gStackPointer = gStackPointer - 1
If gStackPointer < 0 Then
gStackPointer = 0
End If
debugStackPop_xit:
On Error Resume Next
Exit Sub
debugStackPop_err:
MsgBox "debugStackPop() failed. Error " & Str(Err) & ": " & Error$, 48, "Error
In Error Handler"
Resume debugStackPop_xit
End Sub
Sub debugStackPush(ByVal theProcedureName As String)
On Error GoTo debugStackPush_err
' PURPOSE: To push a procedure name into the debug stack
' ACCEPTS: The procedure name
Dim i As Integer
gStackPointer = gStackPointer + 1
If gStackPointer <= gStackLimit Then
gDebugStack(gStackPointer) = theProcedureName
Else
gDebugStack(gStackLimit + 2) = theProcedureName
End If
debugStackPush_xit:
On Error Resume Next
Exit Sub
debugStackPush_err:
MsgBox "debugStackPush() failed. Error " & Str(Err) & ": " & Error$, 48,
"Error In Error Handler"
Resume debugStackPush_err
End Sub
Sub zzTestBugAlert()
debugStackPush mModuleName & ": zzTestBugAlert"
On Error GoTo zzTestBugAlert_err
' PURPOSE: To supply a model for using the BugAlert routines and to demo the
routines
'
' NOTES: 1) Fire up a Debug window and type "zzTestBugAlert"
DoCmd.OpenForm "frmNon-Existant"
zzTestBugAlert_xit:
debugStackPop
On Error Resume Next
Exit Sub
zzTestBugAlert_err:
bugAlert False, "This is the supplemental text...."
Resume zzTestBugAlert_xit
End Sub
