max.riservo ha scritto:
Mostra il codice che usi, proponi come vorresti fare e poi, se serve, il forum ti darà i suggerimenti necessari ...
Questo è il codice:
Public Function CheckConnect() As Integer
' It is also called by function CheckStartup (called from frmSplash)
' It calls functions AttachAgain and GetFileName as needed
Dim db As DAO.Database, rst As DAO.Recordset, tdf As DAO.TableDef
Dim rstV As DAO.Recordset, intFirst As Integer, intI As Integer
Dim strFilePath As String, strPath As String, varRet As Variant
Dim strConnect As String, blnNeedReattach As Boolean
Dim strDataFileName As String, strPwd As String
' Set an Error trap
On Error GoTo CheckConnect_Err
' Point to this database
Set db = DBEngine(0)(0)
' Turn on the progress meter on the status bar
varRet = SysCmd(acSysCmdInitMeter, "Verifying data tables...", db.TableDefs.count)
' Loop through all TableDefs
blnNeedReattach = False
For Each tdf In db.TableDefs
' Looking for attached tables
If (tdf.Attributes And dbAttachedTable) Or (tdf.Attributes And dbAttachedODBC) Then
'per ogni tabella verifico a che datafile appartiene
strDataFileName = GetFileFromPath(GetDBFromstrConn(tdf.Connect))
'poi se il nome del datafile è quello dell'applicazione
If strDataFileName = gstrDataFile Or IsNothing(strDataFileName) Then
strPath = gstrApplicationPath & "\" & gstrDBPath
Else
strPath = GetDBPath(gstrDataFile)
End If
'cerco la password nella tabella di gestione database ztblDBPath
strPwd = GetDBPwd(strDataFileName)
If gblnODBC Then
strConnect = gstrODBC
Else
strConnect = "MS Access;PWD=" & strPwd & ";DATABASE=" & strPath & "\" & strDataFileName & ";"
End If
'verifico che il percorso sia lo stesso dichiarato nella tabella di boot
If tdf.Connect = strConnect Then
' Try to open the table
' Use alternate recordset if already processed the first
If intFirst = True Then
Set rst = tdf.OpenRecordset()
' This one OK - close it
rst.Close
' And clear the object
Set rst = Nothing
Else
' Doing the first one - use alternate
' recordset and leave it open to speed up the process
Set rstV = tdf.OpenRecordset()
' OK - set "first processed" flag
intFirst = True
End If
Else
blnNeedReattach = True
End If
End If
' Update the progress counter
intI = intI + 1
varRet = SysCmd(acSysCmdUpdateMeter, intI)
Next tdf
If blnNeedReattach Then
Resume CheckConnect_Err
End If
' Got through them all - clear the progress meter
varRet = SysCmd(acSysCmdClearStatus)
' Turn off the hourglass
DoCmd.Hourglass False
' Close the "first" recordset
'rstV.Close
' and clear it
Set rstV = Nothing
' Set a good return
CheckConnect = True
CheckConnect_Exit:
Exit Function
CheckConnect_Err:
' Clear the error
Err.Clear
' Set new error trap
On Error GoTo CheckConnect_Err2
' If we successfully got the "first" one open
If intFirst = True Then
' Close and clear it
rstV.Close
Set rstV = Nothing
End If
' Turn off the hourglass for now
DoCmd.Hourglass False
' .. and clear the status bar
varRet = SysCmd(acSysCmdClearStatus)
' Call the generic re-attach code ztbl
If AttachAgain_ztbl() = -1 Then
' Got a good re-attach
' Set OK return
CheckConnect = True
' Done
Exit Function
End If
' No success to this point
' Tell the user about the problem - about to show an open file dialog
MsgBox "There's a temporary problem connecting to the " & gstrShortTitle & " data. " & _
"Please locate the " & gstrShortTitle & " data file in the following dialog.", _
vbInformation, gstrAppTitle
' Set up the default file name
strFilePath = gstrDataFile
' Call the file dialog function
If Not (GetFileName(strFilePath)) Then
' Tell user of error
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 open application again. ", vbCritical, gstrAppTitle
' Set Failed return
CheckConnect = False
' Done
Exit Function
End If
' Open the "info" form telling what we're doing
DoCmd.OpenForm "frmReconnect"
' .. and be sure it has the focus
Forms!frmReconnect.SetFocus
' Try calling the attach code again
If AttachAgain(strFilePath) = 0 Then
MsgBox "Relinking of attached tables failed. The file " & gstrDataFile & " must " & _
" be in the folder you located and cannot be renamed." & _
vbCrLf & vbCrLf & "You can open frmCopyright to try again.", _
vbCritical, "Catalogo Materiali"
' Close and bail
CheckConnect = False
Exit Function
End If
' Close the reconnect "splash" form
DoCmd.Close acForm, "frmReconnect"
' All OK
CheckConnect = True
Exit Function
CheckConnect_Err2:
' Got an unexpected error
' Tell user-
MsgBox "Unexpected error checking attached tables. " & Err & ", " & Error, vbCritical
' Log it
ErrorLog "CheckConnect", Err, Error
' Bail
CheckConnect = False
' Close the info form if it is open
If IsFormLoaded("frmReconnect") Then DoCmd.Close acForm, "frmReconnect"
' ... bail
Resume CheckConnect_Exit
End Function
la funzione viene richiamata dopo l'evento timer della finestra frmSplash che è la finestra di avvio del FE