Revinculando tabelas via código

(P) No meu front-end uso diversas tabelas vinculadas, de diversos bancos de dados back-end. Como posso ter certeza que todas as tabelas sejam conectadas quando o front-end é aberto?

Autor: Dev Hashish

(R) Vove pode percorrer a coleção Tabledefs para ver quais tabelas estão com a propriedade Connect ativa. Se Connect estiver preenchida, reconecte a tabela usando o banco de dados especificado na string.

Aqui está uma função (fRefreshLinks) que deve ser executada na abertura do banco de dados. A função verifica cada tabela no banco de dados no qual o código está sendo executado e tenta localizar a fonte de dados para a tabela se a propriedade Connect estiver preenchida.

Se o banco de dados especificado para a tabela vinculada não estiver presente, o código abre a caixa de diálogo GetOpenFileName para que o usuário possa selecionar uma fonte alternativa.

Nota28-Oct-2005 19:59plicativo.

'***************** Início do Código ***************
' Este código foi originalmente escrito por Dev Ashish.
' Ele não deve ser alterado ou distribuído,
' exceto como parte de um aplicativo.
' Use-o livremente em qualquer aplicativo,
'28-Oct-2005  19:59Código cortesia de 
' Dev Ashish
'
Function fRefreshLinks() As Boolean
Dim strMsg As String, collTbls As Collection
Dim i As Integer, strDBPath As String, strTbl As String
Dim dbCurr As DATABASE, dbLink As DATABASE
Dim tdfLocal As TableDef
Dim varRet As Variant
Dim strNewPath As String

Const cERR_USERCANCEL = vbObjectError + 1000
Const cERR_NOREMOTETABLE = vbObjectError + 2000

    On Local Error GoTo fRefreshLinks_Err

    If MsgBox("Tem certeza que quer reconectar todas as tabelas Access?", _
            vbQuestion + vbYesNo, "Por favor, confirme...") = vbNo Then Err.Raise cERR_USERCANCEL

    'Primeiro pega todas as tabelas vinculadas em uma coleção
    Set collTbls = fGetLinkedTables

    'agora vinculo todas elas
    Set dbCurr = CurrentDb

    strMsg = "Deseja especificar um caminho diferente para as tabelas Access?"
    
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Fonte de dados alternativa...") = vbYes Then
        strNewPath = fGetMDBName("Por favor, selecione a nova fonte de dados.")
    Else
        strNewPath = vbNullString
    End If

    For i = collTbls.Count To 1 Step -1
        strDBPath = fParsePath(collTbls(i))
        strTbl = fParseTable(collTbls(i))
        varRet = SysCmd(acSysCmdSetStatus, "Vinculando '" & strTbl & "'....")
        If Left$(strDBPath, 4) = "ODBC" Then
            'Tabelas ODBC
            'Tabelas ODBC são tratadas em separado
           ' Set tdfLocal = dbCurr.TableDefs(strTbl)
           ' With tdfLocal
           '     .Connect = pcCONNECT
           '     .RefreshLink
           '     collTbls.Remove (strTbl)
           ' End With
        Else
            If strNewPath <> vbNullString Then
                'Tenta desta forma primeiro
                strDBPath = strNewPath
            Else
                If Len(Dir(strDBPath)) = 0 Then
                    'O arquivo não existe. Chama GetOpenFileName
                    strDBPath = fGetMDBName("'" & strDBPath & "' não encontrado.")
                    If strDBPath = vbNullString Then
                        'O usuário clicou em Cancelar
                        Err.Raise cERR_USERCANCEL
                    End If
                End If
            End If

            'O banco de dados back-end existe
            'Colocado aqui já que podemos ter
            'tabelas de diversas fontes de dados
            Set dbLink = DBEngine(0).OpenDatabase(strDBPath)

            'Verifica se a tabela está presente em in dbLink
            strTbl = fParseTable(collTbls(i))
            If fIsRemoteTable(dbLink, strTbl) Then
                'Tudo em ordem. Revincula.
                Set tdfLocal = dbCurr.TableDefs(strTbl)
                With tdfLocal
                    .Connect = ";Database=" & strDBPath
                    .RefreshLink
                    collTbls.Remove (.Name)
                End With
            Else
                Err.Raise cERR_NOREMOTETABLE
            End If
        End If
    Next
    fRefreshLinks = True
    varRet = SysCmd(acSysCmdClearStatus)
    MsgBox "Todas as tabelas Access foram reconectadas com sucesso.", _
            vbInformation + vbOKOnly, _
            "Sucesso"

fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdfLocal = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function
fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3059:

        Case cERR_USERCANCEL:
            MsgBox "Nenhum banco de dados foi especificado. Impossível vincular as tabelas.", _
                    vbCritical + vbOKOnly, _
                    "Erro ao recuperar vínculos."
            Resume fRefreshLinks_End
        Case cERR_NOREMOTETABLE:
            MsgBox "A tabela '" & strTbl & "' não foi encontrada no banco de dados." & _
                    vbCrLf & dbLink.Name & ". Impossível recuperar vínculos.", _
                    vbCritical + vbOKOnly, _
                    "Erro ao r4ecuperar vínculos."
            Resume fRefreshLinks_End
        Case Else:
            strMsg = "Informação de erro..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Função: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Descrição: " & Err.Description & vbCrLf
            strMsg = strMsg & "Erro nº: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg, vbOKOnly + vbCritical, "Erro"
            Resume fRefreshLinks_End
    End Select
End Function

Function fIsRemoteTable(dbRemote As DATABASE, strTbl As String) As Boolean
Dim tdf As TableDef
    On Error Resume Next
    Set tdf = dbRemote.TableDefs(strTbl)
    fIsRemoteTable = (Err = 0)
    Set tdf = Nothing
End Function

Function fGetMDBName(strIn As String) As String
'Calls GetOpenFileName dialog
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Bancos Access(*.mdb;*.mda;*.mde;*.mdw) ", _
                    "*.mdb; *.mda; *.mde; *.mdw")
    strFilter = ahtAddFilterItem(strFilter, _
                    "Todos os arquivos (*.*)", _
                    "*.*")

    fGetMDBName = ahtCommonFileOpenSave(Filter:=strFilter, _
                                OpenFile:=True, _
                                DialogTitle:=strIn, _
                                Flags:=ahtOFN_HIDEREADONLY)
End Function

Function fGetLinkedTables() As Collection
'Devolve todas as tabelas vinculadas
Dim collTables As New Collection
Dim tdf As TableDef, db As DATABASE
Set db = CurrentDb
    db.TableDefs.Refresh
    For Each tdf In db.TableDefs
        With tdf
            If Len(.Connect) > 0 Then
                If Left$(.Connect, 4) = "ODBC" Then
                '    collTables.Add Item:=.Name & ";" & .Connect, KEY:=.Name
                'ODBC tratado separadamente
                Else
                    collTables.Add Item:=.Name & .Connect, Key:=.Name
                End If
            End If
        End With
    Next
    Set fGetLinkedTables = collTables
    Set collTables = Nothing
    Set tdf = Nothing
    Set db = Nothing
End Function

Function fParsePath(strIn As String) As String
    If Left$(strIn, 4) <> "ODBC" Then
        fParsePath = Right(strIn, Len(strIn) _
                        - (InStr(1, strIn, "DATABASE=") + 8))
    Else
        fParsePath = strIn
    End If
End Function

Function fParseTable(strIn As String) As String
    fParseTable = Left$(strIn, InStr(1, strIn, ";") - 1)
End Function
'***************** Final do Código ***************