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

谢谢红尘如烟无私奉献！我一直在用你的“Access通用系统v1.1”，让我受益匪浅。

   我想，其他用过“Access通用系统v1.1”的人，与我一样，有些小小问题--就是当后台数据库中的业务表，一个个添加时，不得不手动，到“LinkData”函数中去添加一些代码。可能有人与我一样，有这样的想法：当在后台数据库中，每增加一个或多个业务表时，能否自动添加业务表的链接？我想，通过一些处理，应该是可以的，试了多种方法，觉得有一种方法，可让我们轻松起来。因为在后台数据库中，有一个系统表“MSysObjects”，它记录了后台数据库中，所有表的添加与删除。方法如下：
1、我们可以手动（且仅且一次），将“MSysObjects”  表，链接到前台数据库中，并命名为“MSysObjects1”，相应地在“LinkData”函数中去添加两行代码：[gstrSourceTableName(9) = "MSysObjects"，gstrLinkTableName(9) = "MSysObjects1"]，
将“gintTablesCount = 8”修改为“gintTablesCount = 9”，好了，下次打开前台数据库时，后台数据库中系统表“MSysObjects”，就会自动链接到前台数据库中。
2、在“LinkData”函数中，创建一记录集，添加的代码如下：
Dim i As Integer
Dim str As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
str = "select * from MSysObjects1 where left(name,4)<>'usys' and Flags=0 and Type=1 "  '排除系统表，只添加业务表
rs.Open str, CurrentProject.Connection, 3, 3
i = rs.RecordCount
3、重定义：
ReDim gstrSourceTableName(1 To gintTablesCount + i)
ReDim gstrLinkTableName(1 To gintTablesCount + i)
4、循环记录集，将业务表保存在数组中：
'-------------以下为链接业务数据表cgy2012-10-9
If rs.RecordCount >= 1 Then
rs.MoveFirst
For i = 1 To i
      gstrSourceTableName(gintTablesCount + i) = rs("name")
rs.MoveNext
Next
End If
5、将原代码：
[ For intI = 1 To gintTablesCount
      If Trim$(gstrLinkTableName(intI)) = "" Then gstrLinkTableName(intI) = gstrSourceTableName(intI)
      On Error Resume Next
      '删除原来的链接表
      DoCmd.DeleteObject acTable, gstrLinkTableName(intI)
      On Error GoTo Err_LinkData
Next]
修改为：
[ For intI = 1 To gintTablesCount + i
      If Trim$(gstrLinkTableName(intI)) = "" Then gstrLinkTableName(intI) = gstrSourceTableName(intI)
      On Error Resume Next
      '删除原来的链接表
      DoCmd.DeleteObject acTable, gstrLinkTableName(intI)
      'On Error GoTo Err_LinkData '这一句必须注释,cgy2012-12-2
Next]
6、将原代码：
[ '显示进度指示
With clsGuage
      .Caption = "正在链接后台数据库……"
      .Max = gintTablesCount
      For intI = 1 To gintTablesCount
         On Error Resume Next
         DoCmd.DeleteObject acTable, gstrSourceTableName(intI)
         On Error GoTo Err_LinkData
         '创建链接表
         Set tdf = CurrentDb.CreateTableDef(gstrSourceTableName(intI))
SetupPassword:
         tdf.Connect = "MS Access;DATABASE=" & PathName
         If strPassword <> "" Then tdf.Connect = tdf.Connect & ";WD=" & strPassword
         tdf.SourceTableName = gstrSourceTableName(intI)
         tdf.Name = gstrLinkTableName(intI)
         CurrentDb.TableDefs.Append tdf
         '显示进度
         .Value = intI
      Next
End With]
修改为：
[ '显示进度指示
With clsGuage
      .Caption = "正在链接后台数据库……"
      .Max = gintTablesCount + i
      For intI = 1 To gintTablesCount + i
         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
         tdf.SourceTableName = gstrSourceTableName(intI)
         tdf.Name = gstrLinkTableName(intI)
         CurrentDb.TableDefs.Append tdf
         '显示进度
         .Value = intI
      Next
End With]
7、添加代码：
rs.Close
Set rs = Nothing
****************************************************************************************
                           修改后的代码清单
****************************************************************************************
'链接后台数据（即创建链接表）
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 As String
Dim clsGuage As New clsProcessBar

If PathName = "" Then Exit Function

Dim i As Integer
Dim str As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
str = "select * from MSysObjects1 where left(name,4)<>'usys' and Flags=0 and Type=1 "
rs.Open str, CurrentProject.Connection, 3, 3
i = rs.RecordCount

gintTablesCount = 9

ReDim gstrSourceTableName(1 To gintTablesCount + i)
ReDim gstrLinkTableName(1 To gintTablesCount + i)

gstrSourceTableName(1) = "USysUsers"
gstrSourceTableName(2) = "USysUserGroups"
gstrSourceTableName(3) = "USysMenuItems"
gstrSourceTableName(4) = "USysIcons"
gstrSourceTableName(5) = "USysUserRights"
gstrSourceTableName(6) = "USysSoftwareInfo"
gstrSourceTableName(7) = "USysOperateLog"
gstrSourceTableName(8) = "USysErrorLog"
gstrSourceTableName(9) = "MSysObjects"

gstrLinkTableName(7) = "登录/操作日志"
gstrLinkTableName(8) = "错误日志"
gstrLinkTableName(9) = "MSysObjects1"
'-------------以下为链接业务数据表cgy2012-10-9
If rs.RecordCount >= 1 Then
rs.MoveFirst
For i = 1 To i
      gstrSourceTableName(gintTablesCount + i) = rs("name")
rs.MoveNext
Next
End If
'如果没有指定新表名，则使用源表名作为链接表名
For intI = 1 To gintTablesCount + i
      If Trim$(gstrLinkTableName(intI)) = "" Then gstrLinkTableName(intI) = gstrSourceTableName(intI)
      On Error Resume Next
      '删除原来的链接表
      DoCmd.DeleteObject acTable, gstrLinkTableName(intI)
      'On Error GoTo Err_LinkData '这一句必须注释,cgy2012-12-2
Next
'显示进度指示
With clsGuage
      .Caption = "正在链接后台数据库……"
      .Max = gintTablesCount + i
      For intI = 1 To gintTablesCount + i
         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
         tdf.SourceTableName = gstrSourceTableName(intI)
         tdf.Name = gstrLinkTableName(intI)
         CurrentDb.TableDefs.Append tdf
         '显示进度
         .Value = intI
      Next
End With
LinkData = True
Password = strPassword
rs.Close
Set rs = Nothing
Exit_LinkData:
Exit Function
Err_LinkData:
If Err = 3031 Then
      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

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