如何自动更新链接表

miracle-y

   在ACCESS中 想通过加入一个按钮 自动进行链接表更新 请问需要怎么弄 有没有宏可以实现这个功能的 谢谢各位大神了

huangli0356

宏我没用过..模块是在用的.可以参考下.

这个是用链接表方式的重链模块

Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。
   
    Dim dbs As Database, rst As Recordset
   
    Set dbs = CurrentDb

    ' 打开链接表查看表链接信息是否正确。
    On Error Resume Next
    Set rst = dbs.OpenRecordset(CheckTableName)
    rst.Close

    ' 如果没有错误，返回 True 。
    If Err = 0 Then
        CheckLinks = True
    Else
        CheckLinks = False
    End If
   
End Function

Private Function RefreshLinks(strFileName As String) As Boolean
' 刷新到提供表的数据库的链接。如果成功的话返回 True 。

    Dim dbs As Database
    Dim tdf As TableDef

    ' 循环处理此数据库的所有表。
    Set dbs = CurrentDb
    For Each tdf In dbs.TableDefs
        ' 如果表有一个连接串，那么该表是一个链接表。
        If Len(tdf.connect) > 0 Then
            tdf.connect = ";DATABASE=" & strFileName & "WD=" & TablePassword
            Err = 0
            On Error Resume Next
            tdf.RefreshLink         ' 重新链接该表。
            If Err <> 0 Then
                RefreshLinks = False
                Exit Function
            End If
        End If
    Next tdf

    RefreshLinks = True        ' 完成重链接。
   
End Function

Public Function RelinkTables() As Boolean
' 尝试刷新连到“后台数据库”数据库的链接。
' 如果成功，返回 True 。

    Dim strFileName As String
    Dim intError As Integer
    Dim strError As String
   
    Const conMaxTables = 8
    Const conNonExistentTable = 3011
    Const conNotNorthwind = 3078
    Const conNwindNotFound = 3024
    Const conAccessDenied = 3051
    Const conReadOnlyDatabase = 3027
   
    If chonglianjie = False Then
        ' 不能找到“后台数据库”，所以显示打开文件对话框。
        MsgBox "系统检测到数据表：“" & conBackAppTitle & "”链接异常！" & vbCr & _
                "您必须重新定位：“" & conBackAppTitle & "”数据库才能正常使用……", vbExclamation, Title
    End If
    strFileName = GetFileName(3, 1, "取消", CurrentProject.Path & "\Data\data.mdb")
   
    If Dir(strFileName) <> conBackAppTitle Or strFileName = "取消" Then
        strError = "抱歉， 您必须重新定位：“" & conBackAppTitle & "”数据库才能正常使用……"
        GoTo Exit_Failed
    End If

    ' 修复链接。
    If RefreshLinks(strFileName) Then
        RelinkTables = True
        Exit Function
    End If
   
    ' 如果失败， 显示一个错误消息。
    Select Case Err
    Case conNonExistentTable, conNotNorthwind
        strError = "文件 '" & strFileName & "' 不包含所要求的数据库表。"
    Case Err = conNwindNotFound
        strError = "直到您定位了“" & conBackAppTitle & "”数据库，您才能正常使用……"
    Case Err = conAccessDenied
        strError = "因为 " & strFileName & " 是只读的或只读共享的，您不能打开它。"
    Case Err = conReadOnlyDatabase
        strError = "因为本程序是只读的或只读共享的，您不能重新链接表。"
    Case Else
        strError = Err.Description
    End Select
   
Exit_Failed:
    If strFileName <> "取消" Then MsgBox strError, vbCritical, Title
    RelinkTables = False
   
End Function

roych

记得红尘的通用系统里面就有这么一个模块，楼主可以下载来研究下。

笑嘻嘻哦

更新连接表如何办到的啊