Newsgroup: it.comp.appl.access
Titolo: Passaggio da DAO ad ADO

utilizzo questo modulo per riallegare le tabelle ad un server fisso con
access97
come dovrebbe diventare passandolo in ADO?
Option Compare Database
Option Explicit
' Autore Alex - Mantova
' e-mail: 
ik2...@libero.it
Public Const DbDatiPath="\\Server\DB\"
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"
Function GetLink()
If Not ActLink Then
'Questa parte è da tenere
'
      If Not ReLinks() Then
         DoCmd.Close acForm, "Link"
         MsgBox "Relinks non effettuato...", vbCritical, "Errore..."
         '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
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
    '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
    '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 = 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
GRAZIE
CIAO

 come dovrebbe diventare passandolo in ADO?
cut
Ma tu non puoi veramente pensare che ora uno si metta qui a riscriverti
tutto sto codice.
Inizia a eliminare currentdb e sostituiscilo (non brutamente ma con i metodi
e le proprieta' appropriate) con currentproject.
il path e' currentproject.path
poi procedi passo passo.
Sib

 ha scritto nel messaggio
news:Gm8Xa.222953$Ny5.6...@twister2.libero.it...

Mi pare di essere parente con l'Autore...! ;-)
Ma a parte ciò, perchè devi passare ad ADO, hai esigenze
di usare SERVER SQL come BE oppure usi sempre ACCESS
come BE sul Server dati..........????
Ti faccio questa domanda perchè il passaggio ad ADO si fa solo
nel caso si debba abbandonare il BE(Access) per passare ad un
Database SQL come SQL_SERVER oppure MySQL o altri.
Nel caso continui ad usare Access-Access sarebbe un lavoro inutile
anzi ne appesantiresti il codice e diverrebbe più lento, in quanto il motore
JET di Access è nato per lavorare con DAO, quindi anche convertendo
in ADO lui dovrebbe compiere il doppio del lavoro per gestire tutto
sempre con DAO.
Saluti.
@Alex.

"Sib" <si...@SPAMiol.it> ha scritto nel messaggio
news:0O9Xa.19696$cl3.7...@news2.tin.it...

Pagando visto che sono il Papà di quella sbrodolata si può fare...!
Non essere sempre assolutista, sono in cerca d'affari........!
@Alex.

 Non essere sempre assolutista, sono in cerca d'affari........!
be', se vuoi andarci tu a scriverglielo sul pc ;-)
Sib

"Sib" <si...@SPAMiol.it> ha scritto nel messaggio
news:%X9Xa.19731$cl3.7...@news2.tin.it...

Non facciamo adesso una gara al ribasso, ne andrebbe della categoria.....!
Occorre fare cartello come tutti gli Albo professionali che si
rispettino....!
Ci mettiamo d'accordo per questo, poi il prossimo ecc......!
@Alex.


Sono d'accordo, facciamo un bel Cartello (alla faccia dell'antitrust, tanto
per i provvedimenti che prendono in italia fanno ridere).
Vabbe', questo lo lascio a te... ;-)
Ciao
Sib

 @Alex.
si devo passare ad un BE con MSDE
ma la parte da modificare è questa?
