Sezione demo e codice vario - Novità

'(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 Sub 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
strDatabase = CurrentProject.Path & "\tuoNomeDb"
' password default
Dim linkPassword As String
linkPassword = ""
' test db BE
If Dir(strDatabase, vbArchive) = "" Then
    MsgBox "Non trovato BE.  Impossibile eseguire il ricollegamento tabelle per :" & vbCrLf & strDatabase, vbCritical, "Error"
    Exit Sub
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 Sub
        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 Sub