Revincular tabelas de diferentes fontes de dados

Temos diversos casos em que um banco de dados Access usa tabelas vinculadas com origem em diferentes fontes de dados (ODBC, Excel, FoxPro, etc). Aqui está uma rotina genérica que pode fazer a vinculação a todas as fontes de dados, não importando o tipo de fonte.

Autores: Timothy Pascoe e Lyle Fairfield

Esta rotina pode ser chamada no momento em que o banco de dados está sendo aberto. Eis um exemplo de chamada à função de revinculação no evento Ao fechar de uma tela de apresentação (splash screen).

Private Sub Form_Close()
    If fRefreshLinks = False Then
        MsgBox "Os vínculos do banco de dados não foram atualizados. O aplicativo " _
        & "não funciona e será encerrado."
        DoCmd.Quit
    End If
End Sub
            

Nota: Este código necessita da rotina GetOpenFileName, fornecida pot .Assegure-se de copiar a função apresentada neste artigo.

Este código deve ser copiado para um módulo padrão.

'*********** Início do Código ************
' Este código foi escrito originalmente por Timothy Pascoe e Lyle Fairfield
' Ele não deve ser alterado ou distribuído,
' exceto como parte de um aplicativo.
' Use-o livremente em qualquer aplicativo,
' desde que esta nota de copyright não seja altarada.
'
' Código cortesia de 
' Timothy Pascoe e Lyle Fairfield
'
Const IntAttachedTableType As Integer = 6
Const ALLFILES = "Todos os arquivos"

Function fGetMDBName(strIn As String) As String
'Chama a caixa de diálogo GetOpenFileName
Dim strFilter As String

    strFilter = ahtAddFilterItem(strFilter, _
                    "Banco de dados 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 fRefreshLinks() As Boolean
' Código cortesia de:
' Banco de dados Microsoft Access 95 Solutions
' Modificado para múltiplos Back-ends por Lyle Fairfield
' Atualizado para tratar cancelamento/seleção incorreta por Timothy J. Pascoe
' Exceto onde indicado.

    Dim dbs As Database
    Dim rst As Recordset, rstTry As Recordset
    Dim tdf As TableDef
    Dim strOldConnect As String, strNewConnect As String
    Dim strFullLocation As String, strDatabase As String, strMsg As String

    Set dbs = CurrentDb()
    Set rst = dbs.OpenRecordset("SELECT MSysObjects.Connect, MsysObjects.Database, " & _
                             "MSysObjects.Name from MSysObjects " & _
                             "WHERE MSysObjects.Type = " & IntAttachedTableType)
    If rst.RecordCount <> 0 Then
        rst.MoveFirst
        Do
            On Error Resume Next
            Set rstTry = dbs.OpenRecordset(rst![Name].Value)
                If Err = 0 Then
                    rstTry.Close
                    Set rstTry = Nothing
                Else
                    On Error GoTo fRefreshLinks_Err
                    strFullLocation = rst.Name
                    strDatabase = FileName(strFullLocation)
                    Set tdf = dbs.TableDefs(rst![Name].Value)
                    strOldConnect = tdf.Connect
                    strNewConnect = findConnect(strDatabase, tdf.Name, strOldConnect)
                    'If strNewConnect = "" Then
                        'Err.Raise
                    'Else
                        For Each tdf In dbs.TableDefs
                            If tdf.Connect = strOldConnect Then
                                tdf.Connect = strNewConnect
                                tdf.RefreshLink
                            End If
                        Next tdf
                        dbs.TableDefs.Refresh
                    'End If
                End If
                Err = 0
            rst.MoveNext
            If rst.EOF Then
                Exit Do
            End If
        Loop
    End If

fRefreshLinks_End:
    Set tdf = Nothing
    Set rst = Nothing
    Set rstTry = Nothing
    fRefreshLinks = True
    Exit Function

fRefreshLinks_Err:
    fRefreshLinks = False
    Select Case Err
        Case 3024:

        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"
    End Select
    Exit Function
End Function

Function findConnect(strDatabase As String, strFileName As String, strConnect As String) As Variant
    Dim strSearchPath As String, strFileType As String, strFileSkelton As String
    Dim aExtension(6, 1) As String, i As Integer, _
    strFindFullPath As String, strFindPath As String, strParameters As String
    strSearchPath = directoryFromConnect(strConnect)
    strFileType = "All Files"
    strFileSkelton = "*.*"
    aExtension(0, 0) = "dBase"
    aExtension(0, 1) = ".dbf"
    aExtension(1, 0) = "Paradox"
    aExtension(1, 1) = ".db"
    aExtension(2, 0) = "FoxPro"
    aExtension(2, 1) = ".dbf"
    aExtension(3, 0) = "Excel"
    aExtension(3, 1) = ".xls"
    aExtension(4, 0) = "Text"
    aExtension(4, 1) = ".txt"
    aExtension(5, 0) = "Exchange"
    aExtension(5, 1) = ".*"
    aExtension(6, 0) = "Access"
    aExtension(6, 1) = ".mdb"
    For i = 0 To 6
        If InStr(strConnect, aExtension(i, 0)) <> 0 Then
            strFileName = strFileName & aExtension(i, 1)
            strFileSkelton = "*" & aExtension(i, 1)
            strFileType = aExtension(i, 0)
            Exit For
        End If
    Next i

    strFindFullPath = findFile(strDatabase, strSearchPath, strFileType, strFileSkelton)
    If strFindFullPath <> "" Then
        strFindPath = strPathfromFileName(strFindFullPath)
        strParameters = parametersFromConnect(strConnect)
        If InStr(strFindFullPath, "dbf") <> 0 Then
            findConnect = strParameters & strFindPath
        Else
            findConnect = strParameters & strFindFullPath
        End If
    End If
End Function
Function directoryFromConnect(strConnect As String) As String
    directoryFromConnect = Mid(strConnect, InStr(strConnect, "DATABASE=") + 9)
End Function
Function parametersFromConnect(strConnect As String) As String
    parametersFromConnect = left(strConnect, InStr(strConnect, "DATABASE=") + 8)
End Function
Function strPathfromFileName(strFileName As String) As String
    Dim i As Integer
    For i = Len(strFileName) To 1 Step -1
        If Mid(strFileName, i, 1) = "\" Then
            Exit For
        End If
    Next i
    strPathfromFileName = left(strFileName, i - 1)
End Function
Function findFile(strDatabase, strSearchPath, strFileType, strFileSkelton) As String

    Dim strSelectedDatabase As String, strFullLocation As String, intlen As Integer, i As Integer
    Dim strIn As String
    
    Do
        strIn = "Onde encontro " & strDatabase & "?"
        findFile = Trim(fGetMDBName(strIn))
        strSelectedDatabase = FileName(findFile)
        If strSelectedDatabase = "" Then
            Exit Do
        ElseIf strDatabase <> strSelectedDatabase Then
            MsgBox "Você selecionou " & strSelectedDatabase & _
                 "@This is not the correct database.@Please select " & _
                 strDatabase & ".", vbInformation + vbOKOnly
        End If
    Loop Until strSelectedDatabase = strDatabase

End Function

Public Function FileName(strFullLocation As String)

    Dim intlen As Integer, i As Integer

    'Pega o nome do banco de dados para uso na barra de título do formulário 'Find File'
    intlen = Len(strFullLocation)
    For i = intlen To 1 Step -1
        If Mid$(strFullLocation, i, 1) = "\" Then
            FileName = right$(strFullLocation, intlen - i)
            Exit For
        End If
    Next i

End Function
'*********** Final do código ************