自动链接表的程序代码

时　间:2010-11-30 00:00:00
作　者:engineeryyk   ID：16200  城市：深圳
摘　要:数据库位置不可避免移动，重新链接不可避免
正　文:

 Dim dbs As Database

 Dim Tdf As TableDef

 Dim Lianjie As String

 Dim MingCheng As String

 On Error GoTo err1

 链接表 = False

 MingCheng = CurrentProject.Path & "\" & 数据库名

  '如果有链接表，则删除

 Set dbs = CurrentDb

 For Each Tdf In CurrentDb.TableDefs

  If Len(Tdf.Connect) > 0 Then

   '如果是链接表，则删除

   DoCmd.DeleteObject acTable, Tdf.Name

  End If

 Next Tdf

 dbs.Close

 '重新建立表链接

 '设置密码字符串

 If 密码 <> "" Then

  Lianjie = ";PWD=" & 密码

 Else

  Lianjie = ";"

 End If

 Set dbs = OpenDatabase(MingCheng, False, False, Lianjie)

 For Each Tdf In dbs.TableDefs

  '如果是本地表才连接

  If Len(Tdf.Connect) = 0 And Tdf.Attributes = 0 Then

   DoCmd.TransferDatabase acLink, "Microsoft Access", MingCheng, acTable, Tdf.Name, Tdf.Name, False

  End If

 Next Tdf

 dbs.Close

 Set dbs = Nothing

 链接表 = True

 Exit Function

err1:

    链接表 = False

    MsgBox Err.Description, vbExclamation, "错误！"

End Function