重建后台数据库链接函数

todaynew

'重建后台数据库链接函数
Function MyTrdb(Fname As String)
'功能：重建表链接。
'参数：Fname：后台数据库完整文件名
'示例：MyTrdb(CurrentProject.Path & "\后台数据库.mdb")
Dim obj As AccessObject, dbs As Object
Dim tbnmae As String
On Error GoTo MyTrdb_Err
   
    Set dbs = Application.CurrentData
    For Each obj In dbs.AllTables
        tbnmae = obj.Name
        If InStr(obj.Name, "MSys") = 0 Then
            DoCmd.DeleteObject acTable, _
bnmae                                                        '删除链接
            DoCmd.TransferDatabase acLink, "Microsoft Access", _
Fname, acTable, tbnmae, tbnmae, False         '建立链接
        End If
    Next obj
MyTrdb_Exit:
    Exit Function
MyTrdb_Err:
    MsgBox Error$
    Resume MyTrdb_Exit
End Function

koutx

收了.不错.

aslxt

谢谢分享，看起来好像不止删除链接表，而是删除用户表。啊？
If InStr(obj.Name, "MSys") = 0 Then
  DoCmd.DeleteObject acTable, tbnmae                                                        '删除链接
DoCmd.TransferDatabase acLink, "Microsoft Access", Fname, acTable, tbnmae, tbnmae, False  '建立链接
End If

todaynew

谢谢分享，看起来好像不止删除链接表，而是删除用户表。啊？
If InStr(obj.Name, "MSys") = 0 Then
  DoCmd.DeleteObject acTable, tbnmae                                                        '删除链接
D ...
aslxt 发表于 2009-9-2 11:16

不会吧？如果前台还有用户表的话，加if排除即可。

aslxt

4# todaynew
是啊，有一些程序在前台还有用户表。当然是可以排除的。我的意思是你的标题看起来是重新链接后台表，而实际是删除用户表-再链接后台表而已。

todaynew

4# todaynew
是啊，有一些程序在前台还有用户表。当然是可以排除的。我的意思是你的标题看起来是重新链接后台表，而实际是删除用户表-再链接后台表而已。
aslxt 发表于 2009-9-2 12:42

有道理
是否可以通过表的属性(Type之流)来进行排除呢？

aslxt

可以通过MSysObjects表的database字段来排除。如果是本地表，该字段为空值，他记录的是链接表的mdb文件路径，还可以选择性地删除某个后台的链接而保留其他后台的链接

fnsmydyang

精彩问答，收藏了，谢谢

todaynew

可以通过MSysObjects表的database字段来排除。如果是本地表，该字段为空值，他记录的是链接表的mdb文件路径，还可以选择性地删除某个后台的链接而保留其他后台的链接
aslxt 发表于 2009-9-2 16:55

很好的建议！
由此来看，不如遍历MSysObjects表，直接修改其地址，以此解决问题更为简单。
谢谢aslxt同志指点！

todaynew

如大师们能把议论结果用代码贴出,则不失为一件功德之举!切盼!
zmt 发表于 2009-9-3 14:22

非大师，初学而已。我想代码大体可以如下：
Function MyURL(Fname As String)
'功能说明:重建表链接。
'参数：Fname：后台数据库完整文件名
'示例：MyTrdb(CurrentProject.Path & "\后台数据库.mdb")

Dim rs As New ADODB.Recordset
Dim ssql As String
Dim i As Long

ssql = "select * from MSysObjects where Type=6"
rs.Open ssql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

For i = 1 To rs.RecordCount
    if rs("Database") <> Fname then
          rs("Database") = Fname
          rs.Update
    end if
    rs.MoveNext
Next

End Function

如嫌记录集啰嗦的话，用更新查询也可。如下：

Function MyURLSQL(Fname As String)
'功能说明:重建表链接。
'参数：Fname：后台数据库完整文件名
'示例：MyTrdb(CurrentProject.Path & "\后台数据库.mdb")
Dim ssql As String
If Nz(DCount("*", "MSysObjects", "Type=6 and Database='" & Fname & "'"), 0) = 0 Then Exit Function
ssql = "UPDATE MSysObjects SET MSysObjects.[Database] = '" & Fname & "'"
ssql = ssql & " WHERE Type=6 AND Database<>'" & Fname & "'"
CurrentDb.Execute ssql
End Function