Newsgroup: it.comp.appl.access
Titolo: riallegare tabelle in automatico

Ho finalmente saputo mettere in pratica quanto consiglia l'ottimo Alessandro
Baraldi in merito all'oggetto.
Quello che non riesco ancora ad evitare è un fastidioso messaggio di sistema
"Microsoft Access .- Impossibile trovare il file C:\.....  etc". Dando l'Ok
a questo messaggio, però, parte regolarmente la macro autoexec e quindi
tutto va a buon fine.
Guardando il codice non mi sembra ci sia niente....
Un saluto a tutti!

 ha scritto nel messaggio
news:41e41693$0$8204$5fc...@news.tiscali.it...

Fai un Debug seguendo passo passo la Routine, oppure posta il Codice che hai
usato
per il Relink, detta così parrebbe strano e difficilmente valutabile.
P.S. spero tu non abbia usato la rouitne che ho postato io qualche anno fà.
    Nel caso affermativo, buttala ed usa il metodo di Antonio Biso
Fammi sapere.
-- 
@Alex (Alessandro Baraldi)
---------------------------------------------------------------------------
http://www.sitocomune.com/
http://www.mantuanet.it/alessandro.baraldi/
---------------------------------------------------------------------------

 ha scritto nel messaggio
news:cs18pe$rj9$1...@lacerta.tiscalinet.it...

Ciao Alex, ho usato questo tuo codice:
a me sembra molto ben fatto...
Anche Roberto Massoni è d'accordo... (vedi post precedenti)
per me poi... tu rimani un faro!
'PASSWORD=barbara
'----------------------------------------------------------------------
'Per utilizzare il modulo:
'Inserire nella MACRO AUTOEXEC
'ESEGUICODICE-----> GetLink()
'per comodità la Macro 1AUTOEXEC è inserita, ma per non renderla
'eseguibile ho inserito "1"-AUTOEXEC, rinominare senza "1"
'----------------------------------------------------------------------
Option Compare Database
Option Explicit
' Autore Alex - Mantova
' e-mail: 
ik2...@libero.it
'**********************************************************************
'Questo modulo è in grado di effettuare il Refresh del Collegamento
'delle tabelle tra Backend e Frontend in modo automatico.
'Per come è strutturato il Batabase(FE) e quello di BE possono essere nella
stessa
'posizione(Path), in alternativa viene proposto di individuare il Percorso
'corretto per ripristinare il Link
'
'Per rendere fisso il Collegamento in caso di BE localizzato
'in un SERVER di rete impostare la riga seguente con l'indirizzo
'del SERVER in modo RELATIVO="\\Nomeserver\Cartella\"
'*******************  RIGA DA ATTIVARE ********************************
'Public Const DbDatiPath="Percorso del Server o Fisso"
'******************* RIGA DA ELIMINARE ********************************
Public DbDatiPath As String
'**********************************************************************
Dim dbCurr As Database
Public FilePath As String
'Definizione della Variabile per l'estrazione dati Link
Type Link
    LName As String
    LPWD As String
    LDBDati As String
    LPathDB As String
End Type
'Numero di Tbl da Linkare per Progressione(Bar)
Private MaxBar As Integer
'Nome della Form con la Barra di progressione
Private Const strForm = "Link"
Private PWD_Err As Boolean
Function GetLink()
'Nel caso di Collegamento al SERVER fisso la seguente
'parte del Codice deve essere rimossa.
On Error GoTo Err_Getlink
If Not ActLink Then
'---------------------------------------------------------------------------
-------
   Dim strMsg As String
   If DbDatiPath = "" Then
Relink_Table:
      strMsg = MsgBox("Mantieni la stessa PATH del FrontEnd (Si/No) ",
vbQuestion + vbYesNo, "Attenzione...!")
      Select Case strMsg
         Case vbYes
            DbDatiPath = GetPathPart(CurrentDb.NAME)
         Case vbNo
            DbDatiPath = cmdlgFile
      End Select
      If DbDatiPath = "" Then
         MsgBox "Impossibile allegare le Tabelle...", vbExclamation, "Relink
Fallito...!"
         Exit Function
      End If
'---------------------------------------------------------------------------
--------
'
'Questa parte è da tenere
      If Not ReLinks() Then
         DoCmd.Close acForm, "Link"
         MsgBox "Relinks non effettuato...", vbCritical, "Errore..."
         Exit Function
         'CHIUDI programma
      Else
         DoCmd.Close acForm, "Link"
'---------------------------------------------------------------------------
-----------
         MsgBox "Relinks effettuato con successo !!!!", vbInformation,
"Effettuato..."
'---------------------------------------------------------------------------
-----------
      End If
'Eliminare la riga seguente nel caso di collegamento Fisso al SERVER
   End If
'---------------------------------------------------------------------------
-----------
End If
DoCmd.OpenForm "Principale"
Exit_GetLink:
   Exit Function
Err_Getlink:
   If err.Number = 3031 Then
      MsgBox "Password di connessione errata...!"
      PWD_Err = True
   End If
   Resume Relink_Table
End Function
Function ActLink() As Boolean
    Dim tdfL As TableDef
    Dim X, link_OK As Integer
    Dim PathName As String
    Set dbCurr = CurrentDb
    'Aggiorna gli oggetti contenuti nell'insieme Tabledefs
    'per riflettere lo schema corrente del database.
    dbCurr.TableDefs.Refresh
    'Restituisce una matrice contenente
    'i dati delle Tbl che hanno il contenuto
    'della proprietà Connect non nullo(le Tbl Collegate)
    'LName=Nome della Tabella
    'LPWD= ;PWD=MiaPassword (nel caso il BE sia protetto)
    'LDBDati=Nome del Database Backend
    'LPathDB=PathCorrente + Nome DB(Backend)
    For Each tdfL In dbCurr.TableDefs
        With tdfL
            If Len(.Connect) > 0 Then
                PathName = ParsePathDBL(.Connect)
                If Len(Dir(PathName)) > 0 Then
                   link_OK = link_OK + 1
                End If
                X = X + 1
            End If
        End With
    Next
    If X < 1 Then
      MsgBox "Nessuna Tbl da Allegare...!"
      ActLink = False
      Exit Function
    Else
       If link_OK < X Then
          ActLink = False
          Exit Function
       End If
    End If
ActLink = True
End Function
Function ReLinks() As Boolean
'Funzione di verifica e Refresh delle Connessioni
'delle Tabelle Collegate ad un DB di BE
    Dim i As Integer, X As Integer
    Dim strConn As String, strMsg As String
    Dim dbLink As Database
    Dim tdfLocal As TableDef
    Dim varRet As Variant
    Dim nx As Variant
    Dim TblLink() As Link
    Dim PWD As String
    On Error GoTo ReLinks_Err
    'Costanti fittizie per generare un errore
    'dedicato con l'istruzione err.raise NumErr
    'ERR_NoTblRemote nel caso non ci sia la TblRemota
    Const ERR_NoTblRemote = vbObjectError + 1000
    'ERR_NoDBRemote nel caso non ci sia il DB(BE)
    Const ERR_NoDBRemote = vbObjectError + 2000
    Set dbCurr = CurrentDb
    'Aggiorna gli oggetti contenuti nell'insieme Tabledefs
    'per riflettere lo schema corrente del database.
    dbCurr.TableDefs.Refresh
    If PWD_Err Then
      PWD = " ;PWD=" & InputBox("Inserisci la Password corretta...", "Enter
PASSWORD")
    End If
    'Restituisce una matrice contenente
    'i dati delle Tbl che hanno il contenuto
    'della proprietà Connect non nullo(le Tbl Collegate)
    'LName=Nome della Tabella
    'LPWD= ;PWD=MiaPassword (nel caso il BE sia protetto)
    'LDBDati=Nome del Database Backend
    'LPathDB=PathCorrente + Nome DB(Backend)
    For Each tdfLocal In dbCurr.TableDefs
        With tdfLocal
            If Len(.Connect) > 0 Then
                ReDim Preserve TblLink(X)
                TblLink(X).LName = .NAME
                TblLink(X).LPWD = IIf(PWD_Err, PWD, ParsePWD(.Connect))
                TblLink(X).LDBDati = ParseFileName(ParsePathDBL(.Connect))
                TblLink(X).LPathDB = DbDatiPath & TblLink(X).LDBDati
                X = X + 1
            End If
        End With
    Next
    If X < 1 Then
      MsgBox "Nessuna Tbl da Allegare...!"
      ReLinks = True
      Exit Function
    End If
    'Predispone la variabile per
    'il prossimo utilizzo
    Set tdfLocal = Nothing
    Test X
    'Inizio fase di Relink
    nx = UBound(TblLink)
    i = 0
IniLinks:
        varRet = SysCmd(acSysCmdSetStatus, "Ricollegamento tabella '" &
TblLink(i).LName & "'....")
        'Verifica che il Database Dati o Backend  esista
        If Esiste(TblLink(i).LDBDati) Then
            'Effettua un collegamento con DAO al DB remoto(BE)
            'per verificare la corrispondenza della Tbl corrente
            strConn = ";DATABASE=" & TblLink(i).LPathDB & TblLink(i).LPWD
            Set dbLink = DBEngine(0).OpenDatabase("", False, True, strConn)
            If fRemTblExist(dbLink, TblLink(i).LName) Then
                'esegue il Refresh del Link
                Set tdfLocal = dbCurr.TableDefs(TblLink(i).LName)
                With tdfLocal
                    .Connect = strConn
                    .RefreshLink
                End With
            Else
                err.Raise ERR_NoTblRemote
            End If
        Else
            err.Raise ERR_NoDBRemote
        End If
        Set dbLink = Nothing
        Call ProgressBar(i, TblLink(i).LName)
    If i <> nx Then i = i + 1: GoTo IniLinks
    ReLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
ReLinks_End:
    Erase TblLink
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
'Gestione errori
ReLinks_Err:
    ReLinks = False
    Select Case err.Number
        Case ERR_NoTblRemote
            'Causato se non c'è corrispondenza tra
            'le Tabelle del Frontend e del Backend
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: ReLinks" & vbCrLf
            strMsg = strMsg & "Tabella remota : " & TblLink(i).LName & _
                              "non trovata ! " & vbCrLf & vbCrLf
        Case ERR_NoDBRemote
            'Causato se non esiste o non si trova il Database
            'di Backend contenente i dati
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: ReLinks" & vbCrLf
            strMsg = strMsg & "Database di Backend : " & TblLink(i).LDBDati
& _
                              " non trovato ! " & vbCrLf & vbCrLf
        Case Else
            'Qualsiasi altro errore non prevedibile
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: ReLinks" & vbCrLf
            strMsg = strMsg & "Impossibile ripristinare la connessione" &
vbCrLf
            strMsg = strMsg & "con le Tabelle dati nel Backend. " & vbCrLf &
vbCrLf
    End Select
    strMsg = strMsg & "Contattare l'assistenza..." & vbCrLf
    MsgBox strMsg, vbOKOnly + vbCritical, "Error..."
    Resume ReLinks_End
End Function
'
'
'-------------------------------- Inizio Funzioni
Personalizzate ------------------------------------
'Gruppo di funzioni specifiche per il recupero dati
'dalla stringa CurrentDB.Tabledef.connect
Function ParsePWD(strIn As String) As String
'Restituisce la Password di collegamento al Db
'contenuta nella stringa Connect della Tbl
'restituisce ";PWD=MiaPassword" se esiste
    Dim strTemp As String
    If InStr(1, strIn, "PWD") <> 0 Then
        strTemp = Right(strIn, Len(strIn) - (InStr(1, strIn, "PWD=")) + 2)
        ParsePWD = Left(strTemp, Len(strTemp) - Len(ParsePathDBL(strIn)) -
10)
    Else
        ParsePWD = ""
    End If
End Function
Function ParsePathDBL(strIn As String) As String
'Funzione specifica per questa applicazione
'Restituisce la Path completa del nome del Db di
'Backend
        ParsePathDBL = Right(strIn, Len(strIn) - (InStr(1, strIn,
"DATABASE=") + 8))
End Function
Function ParseTblName(strIn As String) As String
'Funzione specifica per questa applicazione
'Restituisce il Nome della Tbl contenuto
'nella Stringa Connect
    ParseTblName = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'---------------------------------- Fine Funzioni
Personalizzate ------------------------------------
'
'
'------------------------------------ Inizio Funzioni
Generali --------------------------------------
Public Function GetPathPart(strPath As String) As String
    ' Comments    : Restituisce la Path di un percorso
    ' Parameters  : strPath - Stringa(Percorso completa)
    ' Returns     : GetpathPart=Path(strPath)
    ' Es.         : strPath="C:\Programmi\DataBase.mdb"
    '             : GetPathPart="C:\Programmi\"
    Dim intCounter As Integer
    For intCounter = Len(strPath) To 1 Step -1
      If Mid$(strPath, intCounter, 1) = "\" Then
        Exit For
      End If
    Next intCounter
    GetPathPart = Left$(strPath, intCounter)
End Function
Public Function ParseFileName(FileName As String) As String
'===========================================================================
===========
    'ROUTINE        : Function ParseFileName (strFileName As String ) As
String
    'SCOPO          : Estrae il nome File dal percorso completo
    'ARGOMENTI      : strFileName - il percorso completo del File
    'RESTITUISCE    : Una stringa con il nome del File
    'Es.            : strFileName="C:\Programmi\DataBase.mdb"
    '               : ParseFileName="Database.mdb"
'===========================================================================
===========
    '
    On Error GoTo Err_ParseFileName
         Dim i As Integer
         On Error Resume Next
         For i = Len(FileName) To 1 Step -1
           If Mid(FileName, i, 1) = "\" Then
             Exit For
           End If
         Next
         ParseFileName = Mid(FileName, i + 1)
Exit_ParseFileName:
        Exit Function
Err_ParseFileName:
        MsgBox err.description
        Resume Exit_ParseFileName
End Function
Public Function Esiste(ByVal strFile As String, Optional ByVal strPath As
String) As Boolean
'Verifica l'esistenza del File(strFile) nella Dir(strPath) specificata
    If DbDatiPath = "" Then DbDatiPath = cmdlgFile
    If Len(Dir(DbDatiPath & strFile)) > 0 Then
        Esiste = True
    Else
        Esiste = False
    End If
End Function
Function fRemTblExist(ByVal dbR As Database, ByVal strTbl As String) As
Boolean
'Funzione per la verifica dell'esistenza della Tbl rilevata
'nel Frontend con connessione nel Backend
    Dim tdf As TableDef
    On Error Resume Next
    Set tdf = dbR.TableDefs(strTbl)
    fRemTblExist = (err = 0)
    Set tdf = Nothing
End Function
Public Function cmdlgFile() As String
   Dim loDlg As clsCommDlg
   Dim strFileTitle As String
   Dim strFileName As String
   Dim strFileDir As String
   Set loDlg = New clsCommDlg
   With loDlg
     .Filter = "Database Access (.mdb)|*.mdb"
     .Title = "Cerca il Percorso del Db(BE) per allegare le Tabelle"
     .StartDir = "C:\Programmi"
     .ModeOpen = True
     .Action
     strFileTitle = .FileTitle
     strFileDir = .FileDir
   End With
   cmdlgFile = strFileDir
End Function
'-------------------------------------- Fine Funzioni
Generali --------------------------------------
'-------------------------------------- Funzioni per la Gestione
ProgressBar ------------------------
Function Test(NRec As Integer)
   MaxBar = NRec
   DoCmd.OpenForm strForm
   With Forms(strForm)
       ' Inizializza a 0 la barra di avanzamento
       .retStatus.Width = 0
       .Status.Caption = "0%"
       .Caption = "Attendere..."
       DoCmd.RepaintObject
   End With
End Function
Function ProgressBar(Valore As Integer, Tbl As String)
        'Ciclo di progressione Barra...
   Dim Del As Byte
   Dim nPercento As Single
   Dim nOld As Byte
   If Valore < 2 Then nOld = 0
   With Forms(strForm)
      .lblTblLink.Caption = "Sto collegando la Tabella : " & vbCrLf & Tbl
      ' Ciclo Delay
      For Del = 1 To 200
          DoEvents
      Next
      nPercento = (Valore / MaxBar)
      If Int(nPercento * 100) <> nOld Then
          ' Aggiorna la barra di avanzamento
          .retStatus.Width = CInt(Forms(strForm).Status.Width * nPercento)
          .Status.Caption = Int(nPercento * 100) & "%"
          DoCmd.RepaintObject
          nOld = Int(nPercento * 100)
      End If
   End With
End Function

 per me poi... tu rimani un faro!
Si si proprio il mio....!!!
Beh Roberto è un Signore...!
Il codice è prolisso e farraginoso, fatto in giovane età...! ;-)
Usa questo che è poi uguale a quello di Biso:
http://www.mantuanet.it/alessandro.baraldi/FilesEsempio/TABLES/RelinkAccessTable.txt
Ti spiega come usarlo, si appoggia ad una Tabella nella quale
inserisci il Nome delle Tabella da linkare.
Nel modulo c'è anche una Funzione disabilitata che se abiliti
togliendo il carattere di Commento riempie la tabella con le LinkedTabel.
E' molto più semplice.
Ha lo svantaggio che non gestisce BE differenti, ma vedi tu se è il tuo
caso....!!!
'---------------------------------------------------------------------------
---------------
Se proprio vuoi usare quel codice, oppure hai l'esigenza reale di Linkare BE
differenti con PWD differenti allora ti torna comodo, ma non ho elementi
sufficienti per aiutarti, dovrei riprodurre la tua situazione.
Fammi sapere.
-- 
@Alex (Alessandro Baraldi)


 --------------------------------------------------------------------------
-
Alessandro grazie per l'aiuto.
Io devo collegare, in effetti, ben 5 differenti BE, ma tutti nella stessa
cartella del FE e 1 solo dei BE ha la pwd.
Per cui se tu mi dici che il  codice di Biso non gestisce BE differenti
dovrò utilizzare quello tuo.
 (devo dire che con il tuo, però, ci sono quasi, a parte il messaggio
iniziale che mi dice di non trovare i file ma basta premere ok su questo
messaggio che parte immediatamente e bene la tua routine).
Ho capito bene che il codice di A.Biso non gestisce più di 1 BE ?
Ti ringrazio ancora.

 Ti ringrazio ancora.
Si hai capito bene, ma con una piccola modifica si risolverebbe il tutto.
La tabella(locale) prevista ha solo il campo NomeTabella.
Ora se crei una Tabella con 3 campi:
NomeTabella
NomeBE
Password
Il gioco è fatto.
Dato che il demo di Antonio legge dalla Tabella(Locale) il nome delle
Tabelle
da Relinkare, è semplice estrarre anche Percorso e PWD per ogni tabella
e ricostruire l'intera stringa di connessione dedicata per ogni tabella.
Non devi aggiungere più di 3 righe al codice di Antonio per costruire la
nuova
stringa di connessione.
strConn = ";DATABASE=" & PathFE & rs!NomeBE & "; PWD=" & rs!Passvword
dove PathFE lo ricavi da currentDb.Name oppure da CurrentProject.path
Ora prendiamo uno stralcio del codice tradotto da Paolo Olzi nella versione
A97.
'---------------------------------------------------------------------------
--------------------------
Questo è tratto dall'Originale
'---------------------------------------------------------------------------
--------------------------
' inizio fase di riallegamento tabelle
        Set miodb = CurrentDb()
        Set mioset = miodb.OpenRecordset("tbl_tabelle")
        mioset.MoveFirst
        Num = 1
        ValRestituito = SysCmd(acSysCmdInitMeter, "Si stanno allegando le
tabelle", mioset.RecordCount)
        On Error GoTo gestione_errori_collega
        Do Until mioset.EOF
            ValRestituito = SysCmd(acSysCmdUpdateMeter, Num)
            Set miatable = miodb.TableDefs(mioset.Fields("NOME").Value)
            miatable.Connect = ";DATABASE=" & Nome
            miatable.RefreshLink
            Num = Num + 1
            mioset.MoveNext
        Loop
'---------------------------------------------------------------------------
--------------------------
'---------------------------------------------------------------------------
--------------------------
    Questo diventerà la modifica
'---------------------------------------------------------------------------
--------------------------
' inizio fase di riallegamento tabelle
        Set miodb = CurrentDb()
        Set mioset = miodb.OpenRecordset("tbl_tabelle")
        mioset.MoveFirst
        Num = 1
        ValRestituito = SysCmd(acSysCmdInitMeter, "Si stanno allegando le
tabelle", mioset.RecordCount)
        On Error GoTo gestione_errori_collega
        Do Until mioset.EOF
            ValRestituito = SysCmd(acSysCmdUpdateMeter, Num)
            Set miatable = miodb.TableDefs(mioset.Fields("NOME").Value)
            PathFe=GetPathPart(
miodb.name
)
            miatable.Connect = ";DATABASE=" & PathFe & mioset!NomeBE &
";PWD=" & mioset!Password
            miatable.RefreshLink
            Num = Num + 1
            mioset.MoveNext
        Loop
       ' .......................................
'---------------------------------------------------------------------------
--------------------------
    Funzione aggiuntiva per estrarre il PAth
'---------------------------------------------------------------------------
--------------------------
Public Function GetPathPart(ByVal strPath As String) As String
    Dim intCounter As Integer
    For intCounter = Len(strPath) To 1 Step -1
      If Mid$(strPath, intCounter, 1) = "\" Then
        Exit For
      End If
    Next intCounter
    GetPathPart = Left$(strPath, intCounter)
End Function
Chiaramente devi nel tuo caso specifico eliminare tutta la parte
dedicata al cmdDialog per richiamare la finestra di ricerca del BE
in quanto mi hai detto che sono nella stessa posizione relativa.
Ciao


 --------------------------------------------------------------------------
-
Fantastico Alessandro, non saprò mai come ricambiare la tua enorme
disponibilità!
Sei stato chiarissimo, mi metto subito al lavoro.