如何用VBA备份和压缩ACCESS数据库？

Q：如何用VBA备份和压缩ACCESS数据库？
A：在有些时候，我们会采用ExcelVBA+ACCESS数据库的方式来制作微型数据库系统。在多次操作数据库后，数据库文件会越变越大。在ACCESS里面有压缩数据库的命令，其实我们完全可以通过Excel VBA来压缩数据库。以下代码就是一个备份和压缩的函数，当操作成功时返回True，失败时返回False。

Public Function CompactAccess(ByVal DataPathName As String, ByVal DatePassWord As String, ByVal BFYS As String) As Boolean Dim objJRO As Object Dim TempData As String Set objJRO = CreateObject("JRO.JetEngine") On Error GoTo ErrHandle TempData = ThisWorkbook.Path & "/数据库_" & BFYS If Dir(TempData) <> vbNullString Then Kill TempData If Len(DataPathName) > 0 Then If BFYS = "压缩" Then If Len(DatePassWord) > 0 Then '数据库有密码的情况 objJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ & DataPathName & ";Jet OLEDB:Database Password=" _ & DatePassWord, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " _ & TempData & ";Jet OLEDB:Database Password=" & DatePassWord Else '数据库没有密码的情况 objJRO.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ & DataPathName, "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & TempData End If Kill DataPathName '删除原文件 Name TempData As DataPathName '重新命名压缩后的文件 Else FileCopy DataPathName, TempData '直接复制备份 End If CompactAccess = True Exit Function End If ErrHandle: CompactAccess = False End Function

参考以下过程来调用该函数进行压缩或备份：

Sub 备份压缩() Dim BFYS$ BFYS = IIf(Application.InputBox("1、备份数据库" & vbCrLf & "2、压缩数据库", , 1, Type:=2) = 1, "备份", "压缩") If CompactAccess(ThisWorkbook.Path & "/数据库.MDB", "", BFYS) Then MsgBox BFYS & "数据库成功" Else MsgBox BFYS & "数据库失败" End If End Sub