Oscar Sun

                  Sub 更新連結資料表根目錄() '2015/12/7
On Error GoTo eH
Dim tb As DAO.TableDef, dbPath As String, Drv As String, tbcnt As String
dbPath = CurrentProject.Path
Drv = VBA.Left(dbPath, 2)
For Each tb In CurrentDb.TableDefs
    If tb.Name <> "書照_藏" Then
        tbcnt = tb.Connect
        If VBA.InStr(tbcnt, ":\千慮一得齋") Then
            If VBA.InStr(tbcnt, Drv) = 0 Then
                tb.Connect = VBA.Replace(tbcnt, VBA.Mid(tbcnt, InStr(tbcnt, "=") + 1, 2), Drv, , 1)
                tb.RefreshLink
            End If
        End If
    End If
Next
Exit Sub
eH:
Select Case Err.Number
    Case 3170 '找不到可安裝的 ISAM。
        Debug.Print tb.Name & vbCr & tbcnt
        MsgBox "未安裝/複製資料庫" & vbCr & "資料表: " & tb.Name & vbCr & tbcnt
    Case Else
        Debug.Print Err.Number & Err.Description & vbCr & "資料表: " & tb.Name
        MsgBox Err.Number & Err.Description, vbCritical
End Select
End Sub