Preservar tabelas vinculadas para Acesso bancos de dados na mesma pasta em que as mudanças de pasta

https://stackoverflow.com/questions/534102

22-08-2019
|

Pergunta

Eu tenho dois bancos de dados Access que share ligados tabelas. Eles são implantados juntos em um diretório e acessado por meio de código em um formulário do Word.

Como posso ter certeza de que as ligações são preservadas quando as duas bases de dados são copiados (juntos) para uma pasta diferente? Desde que eu não sou "abertura" do banco de dados, per se (ele está sendo acessado via ADO), eu não sei como escrever código para atualizar as ligações.

Solução

Atualização 14APR2009 Achei que a resposta anterior eu dei aqui estava errada, então eu atualizado com novo código.

Como proceder

Copie o código abaixo para um módulo VBA.
A partir de código ou a partir do Imediato janela no VBA IDE, basta digitar:
```
RefreshLinksToPath Application.CurrentProject.Path
```

Isto irá agora voltar a ligar todas as tabelas vinculadas para usar o diretório onde o aplicativo está localizado.
Ele só precisa ser feito uma vez ou sempre que você vincular novamente ou adicionar novas tabelas.
Eu recomendo fazer isso a partir do código cada vez que você iniciar seu aplicativo.
Você pode então mover seus bancos de dados ao redor sem problemas.

Código

'------------------------------------------------------------'
' Reconnect all linked tables using the given path.          '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to    '
' the moved tables again.                                    '
' If the OnlyForTablesMatching parameter is given, then      '
' each table name is tested against the LIKE operator for a  '
' possible match to this parameter.                          '
' Only matching tables would be changed.                     '
' For instance:                                              '
' RefreshLinksToPath(CurrentProject.Path, "local*")          '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory.             '
'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
    Optional OnlyForTablesMatching As String = "*") As Boolean

    Dim collTbls As New Collection
    Dim i As Integer
    Dim strDBPath As String
    Dim strTbl As String
    Dim strMsg As String
    Dim strDBName As String
    Dim strcon As String
    Dim dbCurr As DAO.Database
    Dim dbLink As DAO.Database
    Dim tdf As TableDef

    Set dbCurr = CurrentDb

    On Local Error GoTo fRefreshLinks_Err

    'First get all linked tables in a collection'
    dbCurr.TableDefs.Refresh
    For Each tdf In dbCurr.TableDefs
        With tdf
            If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
               And (.Name Like OnlyForTablesMatching) Then
                collTbls.Add Item:=.Name & .Connect, key:=.Name
            End If
        End With
    Next
    Set tdf = Nothing

    ' Now link all of them'
    For i = collTbls.count To 1 Step -1
        strcon = collTbls(i)
        ' Get the original name of the linked table '
        strDBPath = Right(strcon, Len(strcon) - (InStr(1, strcon, "DATABASE=") + 8))
        ' Get table name from connection string '
        strTbl = Left$(strcon, InStr(1, strcon, ";") - 1)
        ' Get the name of the linked database '
        strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))

        ' Reconstruct the full database path with the given path '
        strDBPath = strNewPath & "\" & strDBName

        ' Reconnect '
        Set tdf = dbCurr.TableDefs(strTbl)
        With tdf
            .Connect = ";Database=" & strDBPath
            .RefreshLink
            collTbls.Remove (.Name)
        End With
    Next
    RefreshLinksToPath = True

fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdf = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function

fRefreshLinks_Err:
    RefreshLinksToPath = False
    Select Case Err
        Case 3059:

        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg
            Resume fRefreshLinks_End
    End Select
End Function

Este código é adaptado a partir desta fonte: http://www.mvps.org/ acesso / mesas / tbl0009.htm .
Tirei toda a dependência de outras funções para torná-lo auto-suficiente, é por isso que é um pouco mais do que deveria.

Outras dicas

Você está se referindo ao atualizar os links dentro de seu formulário de Word, ou as ligações da tabela ligados entre seus bancos de dados?

Para os primeiros, a melhor maneira que eu sei é manter a seqüência de conexão (s) no nível de módulo dentro do seu projeto documento do Word / VBA e torná-los cordas const. Em seguida, ao definir a seqüência de conexão para seus objetos de conexão ADO, passá-lo a const string de conexão relativa.

Para este último, eu seria tentado a usar um caminho relativo na cadeia de conexão a dados dentro de cada banco de dados Access para o outro. Por exemplo,

Dim connectionString as String

connectionString = ";DATABASE=" & CurrentProject.Path & "\[Database Name Here].mdb"

Se, como você diz, as bases de dados são copiados em conjunto para uma pasta diferente (eu sou assumindo na mesma pasta).

A resposta de Renaud já não funciona no Access 2010 com arquivos do Excel ou CSV.

Eu fiz algumas modificações:

Adaptado ao padrão atual para a seqüência de conexão
Manipulados o caminho do banco de dados de forma diferente para arquivos do Excel (inclui filename) e arquivos CSV (não inclui filename)

Aqui está o código:

Public Function RefreshLinksToPath(strNewPath As String, _
Optional OnlyForTablesMatching As String = "*") As Boolean

Dim collTbls As New Collection
Dim i As Integer
Dim strDBPath As String
Dim strTbl As String
Dim strMsg As String
Dim strDBName As String
Dim strcon As String
Dim dbCurr As DAO.Database
Dim dbLink As DAO.Database
Dim tdf As TableDef

Set dbCurr = CurrentDb

On Local Error GoTo fRefreshLinks_Err

'First get all linked tables in a collection'
dbCurr.TableDefs.Refresh
For Each tdf In dbCurr.TableDefs
    With tdf
        If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = _
           TableDefAttributeEnum.dbAttachedTable) _
           And (.Name Like OnlyForTablesMatching) Then
            Debug.Print "Name: " & .Name
            Debug.Print "Connect: " & .Connect
            collTbls.Add Item:=.Name & ";" & .Connect, Key:=.Name
        End If
    End With
Next
Set tdf = Nothing

' Now link all of them'
For i = collTbls.Count To 1 Step -1
    strConnRaw = collTbls(i)
    ' Get table name from the full connection string
    strTbl = Left$(strConnRaw, InStr(1, strConnRaw, ";") - 1)
    ' Get original database path
    strDBPath = Right(strConnRaw, Len(strConnRaw) - (InStr(1, strConnRaw, "DATABASE=") + 8))
    ' Get the name of the linked database
    strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
    ' Get remainder of connection string
    strConn = Mid(strConnRaw, InStr(1, strConnRaw, ";") + 1, InStr(1, strConnRaw, "DATABASE=") _
                - InStr(1, strConnRaw, ";") - 1)

    ' Reconstruct the full database path with the given path
    ' CSV-Files are not linked with their name!
    If Left(strConn, 4) = "Text" Then
        strDBPath = strNewPath
    Else
        strDBPath = strNewPath & "\" & strDBName
    End If

    ' Reconnect '
    Set tdf = dbCurr.TableDefs(strTbl)
    With tdf
        .Connect = strConn & "Database=" & strDBPath
        .RefreshLink
        collTbls.Remove (.Name)
    End With
Next
RefreshLinksToPath = True

fRefreshLinks_End:
    Set collTbls = Nothing
    Set tdf = Nothing
    Set dbLink = Nothing
    Set dbCurr = Nothing
    Exit Function

fRefreshLinks_Err:
    RefreshLinksToPath = False
    Select Case Err
        Case 3059:

        Case Else:
            strMsg = "Error Information..." & vbCrLf & vbCrLf
            strMsg = strMsg & "Function: fRefreshLinks" & vbCrLf
            strMsg = strMsg & "Description: " & Err.Description & vbCrLf
            strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf
            MsgBox strMsg
            Resume fRefreshLinks_End
    End Select
End Function

Estou, infelizmente, ainda no Access 2007. Eu comecei com um dos blocos de código acima, que não estava trabalhando para mim. Tendo menos poder acesso VBA I simplificado para apenas o primeiro circuito que recebe os caminhos de mesa e atualiza-lo no lugar. O próximo cara correndo para esta pode comentar ou atualização.

Option Compare Database

'------------------------------------------------------------'
' Reconnect all linked tables using the given path.          '
' This only needs to be done once after the physical backend '
' has been moved to another location to correctly link to    '
' the moved tables again.                                    '
' If the OnlyForTablesMatching parameter is given, then      '
' each table name is tested against the LIKE operator for a  '
' possible match to this parameter.                          '
' Only matching tables would be changed.                     '
' For instance:                                              '
' RefreshLinksToPath(CurrentProject.Path, "local*")          '
' Would force all tables whose ane starts with 'local' to be '
' relinked to the current application directory.             '
'
' Immediate window type
' RefreshLinksToPath Application.CurrentProject.Path

'------------------------------------------------------------'
Public Function RefreshLinksToPath(strNewPath As String, _
    Optional OnlyForTablesMatching As String = "*") As Boolean

    Dim strDBPath As String
    'Dim strTbl As String
    'Dim strMsg As String
    Dim strDBName As String
    Dim dbCurr As DAO.Database
    Dim dbLink As DAO.Database
    Dim tdf As TableDef

    Set dbCurr = CurrentDb
    Dim strConn As String
    Dim strNewDbConn1 As String
    Dim strNewDbConn2 As String
    Dim strNewDbConn  As String

    '  On Local Error GoTo fRefreshLinks_Err

    'First get all linked tables in a collection'
    dbCurr.TableDefs.Refresh
    For Each tdf In dbCurr.TableDefs
        With tdf
            If ((.Attributes And TableDefAttributeEnum.dbAttachedTable) = TableDefAttributeEnum.dbAttachedTable) _
               And (.Name Like OnlyForTablesMatching) Then

                strConn = tdf.Connect
                strDBPath = Right(strConn, Len(strConn) - (InStr(1, strConn, "DATABASE=") + 8))
                strDBName = Right(strDBPath, Len(strDBPath) - InStrRev(strDBPath, "\"))
                Debug.Print ("===========================")
                Debug.Print (" connect is " + strConn)
                Debug.Print (" DB PAth is " + strDBPath)
                Debug.Print (" DB Name is " + strDBName)

                strDBNewPath = strNewPath & "\" & strDBName
                Debug.Print (" DB NewPath is " + strDBNewPath)

                strNewDbConn1 = Left(strConn, (InStr(1, strConn, "DATABASE=") - 1))
                strNewDbConn2 = "DATABASE=" & strDBNewPath
                strNewDbConn = strNewDbConn1 & strNewDbConn2
                Debug.Print (" DB strNewDbConn is " + strNewDbConn)

                'Change the connect path
                tdf.Connect = strNewDbConn
                tdf.RefreshLink
            End If
        End With
    Next
End Function

Licenciado em: CC-BY-SA com atribuição

Não afiliado a StackOverflow