Se hai scaricato il demo presente nel link citato:
https://forum.ialweb.it/forum_posts.asp?TID=16257129&PN=3&title=risolto-spostare-file-access-collegati
avrai notato che esiste una macro (Autoexec) che viene eseguita all'avvio, ed effettua solo due operazioni:
- EseguiCodice --> myRicollegaTabelleCurrentFolder
- ApriMaschera --> Menu_Principale
Ora l'esecuzione del codice non fa altro che richiamare la seguente funzione:
' ------------------------------------------
' Funzione che ricollega FE a BE
' ------------------------------------------
' (By65Franco)
' RICOLLEGA TABELLE AL DB QUANDO IL BE SI TROVA NELLA STESSA CARTELLA DELL' FE
' E SOLO SE LA CARTELLA DEL PROGETTO E DIVERSA RISPETTO ALL'ULTIMO RICOLLEGAMENTO DELLE TABELLE
Public Function myRicollegaTabelleCurrentFolder()
Dim myDb As DAO.Database
Dim myTbl As DAO.TableDef
Dim iInt As Integer
' set db name BE - impostare il nome del BE
Dim strDatabase As String
' Impostare qui il nome del database BE (nell'esempio GAS_Dati.mdb)
strDatabase = CurrentProject.Path & "\GAS_Dati.mdb"
' strDatabase = CurrentProject.FullName
' password default
Dim linkPassword As String
linkPassword = "qui inserisci la password di accesso al db dati.mdb"
' test db BE
If Dir(strDatabase, vbArchive) = "" Then
MsgBox "Non trovato BE. Impossibile eseguire il ricollegamento tabelle per :" & vbCrLf & strDatabase, vbCritical, "Error"
Exit Function
End If
' db connection and source folder database
' occurs if db password protected
On Error Resume Next
Set myDb = OpenDatabase(strDatabase, False, True)
If Err.Number = 3031 Then
' password request
Do While Err.Number = 3031
linkPassword = InputBox(Err.Description & vbCrLf & vbCrLf & "Inseri la Password per il Db: " & Dir(strDatabase, vbArchive), "Password")
If linkPassword = "" Then Exit Function
On Error GoTo 0
On Error Resume Next
Set myDb = OpenDatabase(strDatabase, False, True, "; PWD=" & linkPassword)
Loop
End If
On Error GoTo 0
' read table defs
For iInt = 0 To myDb.TableDefs.Count - 1
' retrieve name table
Set myTbl = myDb.TableDefs(iInt)
If myTbl.Attributes = 0 Then
' verifica se ricollegare le tabelle al BE solo nel caso sia cambiata la cartella
Dim varGet As Variant
varGet = DLookup("Database", "MSysObjects", "Name='" & myTbl.Name & "'")
If Not IsNull(varGet) Then
If CurrentProject.Path <> Left(varGet, InStrRev(varGet, "\") - 1) Then
' eliminazione tabella da ricollegare
On Error Resume Next
CurrentDb.Execute "Drop Table [" & myTbl.Name & "];"
On Error GoTo 0
' loop di attesa fino a quando non è aggiornato il db con la cancellazione della tabella dal vecchio link
While Not IsNull(DLookup("Database", "MSysObjects", "Name='" & myTbl.Name & "'"))
DoEvents
Wend
' ricollegamento tabella MsAccess
On Error Resume Next
DoCmd.TransferDatabase acLink, "Microsoft Access", strDatabase, acTable, myTbl.Name, myTbl.Name
' errore ricollegamento tabelle
If Err.Number <> 0 Then
MsgBox "Errore ricollegamento tabelle al db:" & vbCrLf & Err.Description, vbCritical, "Error"
GoTo endErr0
End If
On Error GoTo 0
End If
End If
End If
Next iInt
endErr0:
' close adox
myDb.Close
Set myDb = Nothing
Set myTbl = Nothing
End Function
Il cui funzionamento si basa, come riportato nelle note:
ricollega tabelle al db quando il BE si trova nella stessa cartella dell' FE e solo se la cartella del progetto e diversa rispetto all'ultimo ricollegamento delle tabelle
quindi deve esistere il collegamento fra FE ed BE, al fine di controllare se vi sia diversità fra i path ed in tal caso ricostruire il percorso alle linked-table.
L'operazione di collegamento alle tabelle linkate avviene attraverso la lettura della tabella di sistema MSysObjects, ricostruendo il nuovo path per ciascuna tabella precedentemente linkata ed è possibile notare tale operazione quando si sposta FE e BE in una nuova directory.
Come suggerito da Phil non impiegare come path il desktop (che è legato all'utente) ma piuttosto un percorso compatto nella stringa costitutiva in modo da controllare più semplicemente le operazioni che puoi segeuire anche con il debug in base al codice della suddetta funzione.