将当前数据库中的表备份到另一个数据库中的函数

时　间:2010-06-03 10:29:44
作　者:王樵民   ID：5203  城市：郑州
摘　要:本人介绍一个将当前数据库中的表自动保存到另一个数据库中的函数，适用Access各个版本，如果备份的数据库是Access2007，请将lj = CurrentProject.Path & "\" & 备份数据库名 & ".mdb"，改成lj = CurrentProject.Path & "\" & 备份数据库名 & & ".accdb""

正　文:

如下函数将当前数据库中的表备份到另一个数据库中，调用格式：

Dim Bf As Boolean

Bf=备份("合同数据库备份")

适用Access各个版本，如果备份的数据库是Access2007，请将lj = CurrentProject.Path & "\" & 备份数据库名 & ".mdb"，改成lj = CurrentProject.Path & "\" & 备份数据库名 & & ".accdb""

下面就是这个函数：

Function 备份(备份数据库名) As Boolean

'On Error GoTo err1

Dim lj

Dim obj As AccessObject, dbs As Object

lj = CurrentProject.Path & "\" & 备份数据库名 & ".mdb"

Set fs = CreateObject("Scripting.FileSystemObject")

If Not fs.FileExists(lj) Then

 Set xinAccess = CreateObject("Access.Application")

 xinAccess.NewCurrentDatabase (lj)

 xinAccess.CloseCurrentDatabase

End If

Set dbs = Application.CurrentData

For Each obj In dbs.AllTables

If obj.IsLoaded = True Then DoCmd.Close acTable, obj.Name

 If Mid(obj.Name, 1, 4) <> "MSys" And Mid(obj.Name, 1, 4) <> "USys" Then

  DoCmd.TransferDatabase acExport, "Microsoft Access", lj, acTable, obj.Name, obj.Name, False

 End If

 ' 如果obj 未达到所有表，则继续循环，每次obj增加一个步长；否则退出循环

Next obj

msgbox("数据表备份完成，其文件名为：" & lj)

Err1: