自动重新链接的数据表函数（含access2007，2003下使用）

本文介绍两个函数，链接表函数，用于前后台的数据库管理中，可分别连接Access数据库和SQL数据库，源码示例，（摘自Access 2007开发全书）

请将下列程序放置在公用模块中

1.         链接Access 2007（含Access 2003）中的数据表函数

Public Function 链接表(数据库名 As String, Optional 密码 As String) As Boolean
 '连接指定的数据库中的表

    '2007下使用方法：
 'Call 公用模块.链接表("营销合同管理数据.accdb", "123")
 'Call 公用模块.链接表("营销合同管理数据.accdb")

    '2003下使用方法：

    'Call 公用模块.链接表("营销合同管理数据.mdb", "123")
 'Call 公用模块.链接表("营销合同管理数据.mdb")

 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

2 、链接SQL Server数据库中的表函数
Public Function SQL链接表(数据库名 As String, IP地址 As String, 用户名, Optional 密码 As String) As Boolean
 '连接指定的数据库中的表
 '使用方法：Call 公用模块.SQL链接表("进销存管理系统SQL","127.0.0.1","sa","1234")
 '使用方法：Call 公用模块.SQL链接表("进销存SQL","127.0.0.1","sa")
 Dim dbs As Database
 Dim Tdf As TableDef
 Dim Lianjie As String
 Dim MingCheng As String
 Dim s As String
 'On Error GoTo Err1
 SQL链接表 = False
 MingCheng = ""
  '如果有链接表，则删除
 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
 MingCheng = 数据库名
 '重新建立表链接
 '设置密码字符串
  If 密码 <> "" Then
  Lianjie = "ODBC;DRIVER=SQL Server;SERVER=" & IP地址 & ";UID=" & 用户名 & ";" & "PWD=" & 密码 & ";" & "DATABASE=" & 数据库名
 Else
  Lianjie = "ODBC;DRIVER=SQL Server;SERVER=" & IP地址 & ";UID=" & 用户名 & ";PWD=;" & "DATABASE=" & 数据库名
 End If
 Set dbs = OpenDatabase(MingCheng, True, False, Lianjie)
 For Each Tdf In dbs.TableDefs
  '如果是本地表才连接
  If Len(Tdf.Connect) = 0 And Tdf.Attributes = 0 Then
   s = Mid(Tdf.Name, 5)
   DoCmd.TransferDatabase acLink, "ODBC", Lianjie, acTable, Tdf.Name, s, False
  End If
 Next Tdf
 dbs.Close
 Set dbs = Nothing
 SQL链接表 = True
 Exit Function  

Err1:
    SQL链接表 = False
    MsgBox Err.Description, vbExclamation, "错误！"
End Function