当文件夹更改时,保留相同文件夹中Access DB的链接表

Question

我有两个共享链表的Access数据库.它们一起部署在目录中,并通过Word表单中的代码进行访问.

当两个数据库(一起)复制到另一个文件夹时,如何确保保留链接？由于我不是"打开"数据库本身(它是通过ADO访问),我不知道如何编写代码来刷新链接.

Answer 1

更新14APR2009 我发现我之前给出的答案是错误的,所以我用新代码更新了它.

如何进行

• 将以下代码复制到VBA模块.

• 从代码或VBA IDE中的立即窗口,只需键入:

  RefreshLinksToPath Application.CurrentProject.Path
  

现在,这将重新链接所有链接表以使用应用程序所在的目录.
它只需要完成一次或重新链接或添加新表.
我建议您每次启动应用程序时都从代码中执行此操作.
然后,您可以毫无问题地移动数据库.

码

'------------------------------------------------------------'
' 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

此代码改编自此来源:http://www.mvps.org/access/tables/tbl0009.htm.
我删除了对其他函数的所有依赖,使其自包含,这就是为什么它比它应该更长的原因.