【Access小品】后台数据库重联函数

卡西达

1. Function MyTrdb(Fpath As String, Fname As String)
   
2. '引用：Microsoft Scripting Runtime
   
3. '功能：重建表链接。
   
4. '参数：Fname：后台数据库完整文件名
   
5. '示例：MyTrdb(CurrentProject.Path & "\","后台.mdb")
   
6. 
   
7. Dim myFSO As New FileSystemObject
   
8. Dim obj As AccessObject, dbs As Object
   
9. Dim tbnmae As String, sname As String
   
10. Dim Dname As String
    
11. On Error GoTo MyTrdb_Err
    
12. If myFSO.FileExists(Fpath & Fname) = True Then
    
13. Set dbs = Application.CurrentData
    
14. For Each obj In dbs.AllTables
    
15. If InStr(obj.Name, "MSys") = 0 Then
    
16. If DLookup("Type", "MSysObjects", "name='" & obj.Name & "'") = 6 Then
    
17. Dname = Nz(DLookup("Database", "MSysObjects", "name='" & obj.Name & "'"), "")
    
18. If Fpath & Fname <> Dname Then
    
19. If Dname <> "" Then
    
20. If Mid(Dname, InStrRev(Dname, "\") + 1) = Fname Then
    
21. tbnmae = obj.Name
    
22. sname = DLookup("ForeignName", "MSysObjects", "name='" & obj.Name & "'")
    
23. DoCmd.DeleteObject acTable, tbnmae '删除链接
    
24. DoCmd.TransferDatabase acLink, "Microsoft Access", Fpath & Fname, acTable, sname, tbnmae, False '建立链接
    
25. End If
    
26. End If
    
27. End If
    
28. End If
    
29. End If
    
30. Next obj
    
31. 
    
32. End If
    
33. MyTrdb_Exit:
    
34. Exit Function
    
35. 
    
36. MyTrdb_Err:
    
37. MsgBox Error$
    
38. Resume MyTrdb_Exit
    
39. End Function

复制代码