关于红尘如烟“Access通用系统v1.1”基础上的改进的改进-access专栏

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