Newsgroup: it.comp.appl.access
Titolo: Relink Table

Ciao a tutto il NG
Ho dovuto usato la funzione per riallegare le tabelle (che funziona
benissimo!!!) in quanto spesso il database che installo e' in rete, quindi
vanno rimappati i percorsi.
Ho pero' un problema il mio Db e' formato da 18 Tbl collegate, di cui 16 in
un mdb e 2 in un altro db. Il problema e' che in quella funzione non riesco
a dirgli di cercare in due db.
Come fare????
Ciao


wrote:

e facendo il collegamento su entrambi? che cosa fa?
Saluti.
Emanuele.

 ha scritto nel messaggio
news:ss9b7vchmbitsmdqc...@4ax.com...

Mi da un erroraccio!!!!!! e mi sbatte fuori dalla procedura!!!!
Ciao ciao

...

Ciao, prova con questo codice, che non è farina del mio sacco, ma che
ho adattato alle mie esigenze e che funziona benone:
Option Compare Database
Option Explicit
'**********************************************************************
'Questo modulo è in grado di effettuare il refresh del collegamento
'delle tabelle tra Backend e Frontend in modo automatico, proponendo
'di individuare il percorso corretto per ripristinare il Link
'**********************************************************************
'Quella che segue è la dichiarazione della struttura da passare alla
funzione
'SHBrowseForFolder che permette di mostrare il 'browse folder.
Nell'esempio imposto poi
'soltanto 3 degli elementi della struttura; hOwner che è l'ID della
finestra chiamante,
'lpszTitle che permette di visualizzare una stringa di intestazione e
ulFlags che indica
'di mostrare un tipo di 'visualizzazione di oggetti piuttosto che un
altro nel browse
'folder. Provate a cambiare il valore associato a ulFlags per avere
altre visualizzazioni
'con altri risultati ritornati associati.
Private Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type
'Queste invece sono le costanti che possono essere passate a ulFlags
 
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
'La dichiarazione successiva è della funzione che permette di
richiamare il Browser Folder.
'Si noti che il valore long restituito sarà poi utilizzato dalla
successiva funzione che
'permette di "recuperare" il path e il nome del folder. Questo perchè
la SHBrowseForFolder
'restituisce un puntatore a una struttura che è la lista degli
identificatori a partire dal
'desktop di Windows (che è la radice dello spazio dei nomi del
sistema) e passando per
'tutti i folder che contengono 'l'oggetto. Il PIDL è un puntatore a
questa struttura. Se
'il PIDL identifica un percorso valido, è possibile convertirlo in una
stringa utilizzando
'SHGetPathFromIDList().
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
'La funzione che segue permette appunto di recuperare il percorso e il
folder selezionato
'nel browser.
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
 
'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
      MsgBox "Le tabelle contenenti i dati non sono collegate
correttamente." & Chr(10) & Chr(10) & "Premere il tasto per procedere
con il relink necessario...", vbExclamation + vbOKOnly, "Attenzione"
 
Relink_Table:
      DbDatiPath = BrowseFolder("Selezionare la cartella contenente
gli archivi.") & "\"
 
      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"
 
        strMsg = MsgBox("Il collegamento alle tabelle contenenti i
dati non è stato ripristinato." & Chr(10) & Chr(10) & "Provare ad
effettuarlo di nuovo?", vbCritical + vbYesNo, "Relink fallito")
        If strMsg = vbYes Then
            GoTo Relink_Table
        Else
            Application.Quit
        End If
 
        Exit Function
         'CHIUDI programma
      Else
         DoCmd.Close acForm, "Link"
'--------------------------------------------------------------------------------------
         MsgBox "Il collegamento alle tabelle contenenti i dati è
stato ripristinato." & Chr(10) & Chr(10) & "Premere il tasto per
continuare...", vbInformation, "Relink effettuato con successo"
'--------------------------------------------------------------------------------------
      End If
'Eliminare la riga seguente nel caso di collegamento Fisso al SERVER
   End If
'--------------------------------------------------------------------------------------
End If
DoCmd.OpenForm "PannelloComandiPrincipale"
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 = strMsg & "Relink non effettuato." & 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 = strMsg & "Relink non effettuato." & vbCrLf
            strMsg = strMsg & "Database di Backend: " &
TblLink(I).LDBDati & _
                              " non trovato." & vbCrLf & vbCrLf
        Case Else
            'Qualsiasi altro errore non prevedibile
            strMsg = strMsg & "Relink non effettuato." & vbCrLf
            strMsg = strMsg & "Impossibile ripristinare la
connessione" & vbCrLf
            strMsg = strMsg & "con le tabelle dati nel Backend. " &
vbCrLf & vbCrLf
    End Select
    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 = BrowseFolder("Selezionare la
cartella contenente gli archivi.") & "\" '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 BrowseFolder(szDialogTitle As String) As String
'Viene richiamato il browser e recuperato il path e il folder
  Dim X As Long, bi As BROWSEINFO, dwIList As Long
  Dim szPath As String, wPos As Integer
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    If X Then
        wPos = InStr(szPath, Chr(0))
        BrowseFolder = Left$(szPath, wPos - 1)
    Else
        BrowseFolder = ""
    End If
    If Right(BrowseFolder, 1) = "\" Then BrowseFolder =
Mid$(BrowseFolder, 1, Len(BrowseFolder) - 1)
End Function
'-------------------------------------- Fine Funzioni Generali
--------------------------------------
'--------------------------- Funzioni per la Gestione della
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 = 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


[cut]
piů semplicemente.. hai provato a fare una tabella semplicissima che
contiene i due percorsi delle tabelle, poi dici via codice di linkare le
tabelle dei due database..
praticamente invece di fare un Relink... fai prima una disconessione magari
cancellando tutte le tabelle collegate .. poi le ricolleghi
Io ho fatto una tabelle con i percorsi dei DB e un'altra con le tabelle da
linkare dai vari percosi.. se voui + brigoso.. ma molto efficiente
ciao
---
Outgoing mail is certified Virus Free.
Checked by AVG anti-virus system (
http://www.grisoft.com
).
Version: 6.0.463 / Virus Database: 262 - Release Date: 17/03/03