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
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
WD=" & TablePassword