http://www.accessoft.com/article-show.asp?id=7750者对“Access通用系统v1.1”进行了改动,在手动基础上能自动添加链接表,但是手动添加的MSysObjects的路径是绝对路径,不能移植,与原意图相悖。
在网友SuperQ的帮助下,修改“LinkData”函数,直接访问后台数据库的MSysObjects,实现全自动添加链接表。
修改后的代码如下:
'链接后台数据(即创建链接表)
Public Function LinkData(PathName As String, Optional Password As String) As Boolean
On Error GoTo Err_LinkData
Dim intI As Integer
Dim tdf As Object
Dim strPassword, gstrSourceTable, gstrLinkTable As String
Dim clsGuage As New clsProcessBar
If PathName = "" Then Exit Function
Dim db As Database
Dim ws As Workspace
Dim rst As Recordset
Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(PathName, False, False, "MS Access;PWD=" + Password)
Set rst = db.OpenRecordset("MSysObjects", 1)
If rst.RecordCount > 0 Then
ReDim gstrSourceTableName(1 To rst.RecordCount)
ReDim gstrLinkTableName(1 To rst.RecordCount)
End If
gintTablesCount = 0
Do Until rst.EOF
If rst("Flags") = 0 And rst("Type") = 1 Then
' MsgBox rst!Name
gintTablesCount = gintTablesCount + 1
gstrSourceTableName(gintTablesCount) = rst!Name
'如果没有指定新表名,则使用源表名作为链接表名
If Trim$(gstrLinkTableName(gintTablesCount)) = "" Then gstrLinkTableName(gintTablesCount) = gstrSourceTableName(gintTablesCount)
On Error Resume Next
'删除原来的链接表
DoCmd.DeleteObject acTable, gstrLinkTableName(gintTablesCount)
End If
rst.MoveNext
Loop
'显示进度指示
With clsGuage
.Caption = "正在链接后台数据库……"
.Max = gintTablesCount
For intI = 1 To gintTablesCount
On Error Resume Next
DoCmd.DeleteObject acTable, gstrSourceTableName(intI)
On Error GoTo Err_LinkData '这一句必须注释,cgy2012-12-2
'创建链接表
Set tdf = CurrentDb.CreateTableDef(gstrSourceTableName(intI))
SetupPassword:
tdf.Connect = "MS Access;DATABASE=" & PathName
If strPassword <> "" Then
tdf.Connect = tdf.Connect & "WD=" & strPassword
End If
tdf.SourceTableName = gstrSourceTableName(intI)
tdf.Name = gstrLinkTableName(intI)
CurrentDb.TableDefs.Append tdf
'显示进度
.Value = intI
Next
End With
LinkData = True
Password = strPassword
rst.Close
db.Close
Exit_LinkData:
Exit Function
Err_LinkData:
If Err = 3031 Then
MsgBox Err.Description
If strPassword = "" And Password <> "" Then
strPassword = Password
Resume SetupPassword
Else
strPassword = fInputBox("请输入访问数据库文件 '" & PathName & "' 的正确密码:", "输入密码", True)
If strPassword <> "" Then
Resume SetupPassword
Else
MsgBox "因无有效密码,系统不能识别此数据库文件。", vbCritical
End If
End If
Else
MsgBox Err.Description, vbCritical
End If
Resume Exit_LinkData
End Function
|