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

竹笛

原文作者： 曹光耀    QQ：1779230348
谢谢红尘如烟无私奉献！我一直在用你的“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

竹笛

哈哈，我还特意查了一下，没找到才转发的