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

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:

End Function