MS Access：如何在 VBA 中压缩当前数据库答案

【问题标题】：MS Access: how to compact current database in VBAMS Access：如何在 VBA 中压缩当前数据库
【发布时间】：2010-11-30 09:57:46
【问题描述】：

很简单的问题，我知道。

【问题讨论】：

当然，只是希望 stackOverflow 有所有的答案！

标签： vba database ms-access

【解决方案1】：

如果你想压缩/修复一个外部 mdb 文件（不是你刚才工作的那个）：

Application.compactRepair sourecFile, destinationFile

如果您想压缩正在使用的数据库：

Application.SetOption "Auto compact", True

在最后一种情况下，您的应用将在关闭文件时被压缩。

我的意见：在一个额外的 MDB“压缩器”文件中编写几行代码，当你想压缩/修复 mdb 文件时可以调用它是非常有用的：在大多数情况下，需要压缩的文件不能正常打开了，需要从文件外调用方法。

否则，在 Access 应用程序的每个主模块中，自动压缩默认设置为 true。

如果发生灾难，请创建一个新的 mdb 文件并从错误文件中导入所有对象。您通常会发现无法导入的错误对象（表单、模块等）。

【讨论】：

COMPACT ON CLOSE 在任何设计合理的 Access 应用程序中都是毫无价值的（只有后端需要压缩，而且你永远不会在前端打开它），而且非常危险，因为你没有有机会跳过它（压缩可能会导致某些类型的损坏但仍可访问的数据永久丢失）。
当您使用客户端数据库保存临时数据（例如本地表）时，关闭时压缩文件是有意义的。
有趣的东西大卫。我有紧凑的近距离设置，但可能需要审查。昨天压缩时它挂了一会儿，杀死了这个进程，想知道它是否损坏了我的数据库。当我意识到它压缩到一个临时文件时，松了一口气，但仍然如此。
我说的是临时表，而不是临时数据库。我注意到，当您定期在前端创建临时表时（从后端导入的数据，或菜单表等运行时数据，在登录时从全局菜单表中构建，并根据用户授予选项，或从网络中某处的 xml 文件上传的本地“可用连接”表，或者...）客户端文件有增长的趋势，这受到设置 compactOnClause 选项的限制。我们在压缩之前不备份，因为我们在客户端没有“永久”数据。
对于临时表，最好的选择是避免它们。次优：以编程方式在用户的 %TEMP% 文件夹上创建一个临时数据库并使用该数据库，该数据库可以在关闭应用程序时销毁。

【解决方案2】：

如果您的数据库具有前端和后端。您可以在前端主导航窗体的主窗体上使用以下代码：

Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As String
Dim s1 As Long, s2 As Long

sDataFile = "C:\MyDataFile.mdb"
sDataFileTemp = "C:\MyDataFileTemp.mdb"
sDataFileBackup = "C:\MyDataFile Backup " & Format(Now, "YYYY-MM-DD HHMMSS") & ".mdb"

DoCmd.Hourglass True

'get file size before compact
Open sDataFile For Binary As #1
s1 = LOF(1)
Close #1

'backup data file
FileCopy sDataFile, sDataFileBackup

'only proceed if data file exists
If Dir(sDataFileBackup vbNormal) <> "" Then

        'compact data file to temp file
        On Error Resume Next
        Kill sDataFileTemp
        On Error GoTo 0
        DBEngine.CompactDatabase sDataFile, sDataFileTemp

        If Dir(sDataFileTemp, vbNormal) <> "" Then
            'delete old data file data file
            Kill sDataFile

            'copy temp file to data file
            FileCopy sDataFileTemp, sDataFile

            'get file size after compact
            Open sDataFile For Binary As #1
            s2 = LOF(1)
            Close #1

            DoCmd.Hourglass False
            MsgBox "Compact complete " & vbCrLf & vbCrLf _
                & "Size before: " & Round(s1 / 1024 / 1024, 2) & "Mb" & vbCrLf _
                & "Size after:    " & Round(s2 / 1024 / 1024, 2) & "Mb", vbInformation
        Else
            DoCmd.Hourglass False
            MsgBox "ERROR: Unable to compact data file"
        End If

Else
        DoCmd.Hourglass False
        MsgBox "ERROR: Unable to backup data file"
End If

DoCmd.Hourglass False

【讨论】：

【解决方案3】：

尝试添加这个模块，很简单，只需启动 Access，打开数据库，将“Compact on Close”选项设置为“True”，然后退出。

自动压缩的语法：

acCompactRepair "C:\Folder\Database.accdb", True

返回默认值*：

acCompactRepair "C:\Folder\Database.accdb", False

*没有必要，但是如果你的后端数据库大于 1GB，当你直接进入它并且需要 2 分钟退出时，这可能会很烦人！

编辑：添加了递归遍历所有文件夹的选项，我每晚运行一次以将数据库降至最低。

'accCompactRepair
'v2.02 2013-11-28 17:25

'===========================================================================
' HELP CONTACT
'===========================================================================
' Code is provided without warranty and can be stolen and amended as required.
'   Tom Parish
'   TJP@tomparish.me.uk
'   http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html
'   DGF Help Contact: see BPMHelpContact module
'=========================================================================

'includes code from
'http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for improved error handling

'   v2.02   bugfix preventing Compact when bAutoCompact set to False
'           bugfix with "OLE waiting for another application" msgbox
'           added "MB" to start & end sizes of message box at end
'   v2.01   added size reduction to message box
'   v2.00   added recurse
'   v1.00   original version

Option Explicit

Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _
    , Optional bAutoCompact As Boolean = False) As String
'v2.02 2013-11-28 17:25
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True

'syntax:
'   accSweepForDatabases "path", [False], [True]

'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse":
'   accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")]

Application.DisplayAlerts = False

Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single
Dim SizeBefore As Long, SizeAfter As Long
t = Timer
RecursiveDir colFiles, strFolder, "*.accdb", True  'comment this out if you only have Access 2003 installed
RecursiveDir colFiles, strFolder, "*.mdb", True

    For Each vFile In colFiles
        'Debug.Print vFile
        SizeBefore = SizeBefore + (FileLen(vFile) / 1048576)
On Error GoTo CompactFailed
    If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes"
        acCompactRepair vFile, bAutoCompact
        i = i + 1  'counts successes
        GoTo NextCompact
CompactFailed:
On Error GoTo 0
        j = j + 1   'counts failures
        sFails = sFails & vFile & vbLf  'records failure
NextCompact:
On Error GoTo 0
        SizeAfter = SizeAfter + (FileLen(vFile) / 1048576)

    Next vFile

Application.DisplayAlerts = True

'display message box, mark end of process
    accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB"
    If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails
    MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases"

End Function

Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean
'v2.02 2013-11-28 16:22
'if doEnable = True will compact and repair pthfn
'if doEnable = False will then disable auto compact on pthfn

On Error GoTo CompactFailed

Dim A As Object
Set A = CreateObject("Access.Application")
With A
    .OpenCurrentDatabase pthfn
    .SetOption "Auto compact", True
    .CloseCurrentDatabase
    If doEnable = False Then
        .OpenCurrentDatabase pthfn
        .SetOption "Auto compact", doEnable
    End If
    .Quit
End With
Set A = Nothing
acCompactRepair = True
Exit Function
CompactFailed:
End Function


'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html
'tweaked slightly for error handling

Private Function RecursiveDir(colFiles As Collection, _
                             strFolder As String, _
                             strFileSpec As String, _
                             bIncludeSubfolders As Boolean)

    Dim strTemp As String
    Dim colFolders As New Collection
    Dim vFolderName As Variant

    'Add files in strFolder matching strFileSpec to colFiles
    strFolder = TrailingSlash(strFolder)
On Error Resume Next
    strTemp = ""
    strTemp = Dir(strFolder & strFileSpec)
On Error GoTo 0
    Do While strTemp <> vbNullString
        colFiles.Add strFolder & strTemp
        strTemp = Dir
    Loop

    If bIncludeSubfolders Then
        'Fill colFolders with list of subdirectories of strFolder
On Error Resume Next
        strTemp = ""
        strTemp = Dir(strFolder, vbDirectory)
On Error GoTo 0
        Do While strTemp <> vbNullString
            If (strTemp <> ".") And (strTemp <> "..") Then
                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                    colFolders.Add strTemp
                End If
            End If
            strTemp = Dir
        Loop

        'Call RecursiveDir for each subfolder in colFolders
        For Each vFolderName In colFolders
            Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
        Next vFolderName
    End If

End Function

Private Function TrailingSlash(strFolder As String) As String
    If Len(strFolder) > 0 Then
        If Right(strFolder, 1) = "\" Then
            TrailingSlash = strFolder
        Else
            TrailingSlash = strFolder & "\"
        End If
    End If
End Function

【讨论】：

【解决方案4】：

对于 Access 2013，您可以这样做

Sendkeys "%fic"

这与在键盘上键入 ALT、F、I、C 相同。

可能不同版本的字母顺序不同，但“%”符号表示“ALT”，所以请保留在代码中。您可能只需要更改字母，具体取决于您按 ALT 时出现的字母

Letters that appear when pressing ALT in Access 2013

【讨论】：

或Sendkeys "%yc"
当你有本地方法可用时，不要依赖按键。这可能会导致未定义的行为，因为按键将被发送到任何活动的对象（可能不是您的预期目标）。

【解决方案5】：

回应 jdawgx 的精彩帖子：

请注意上述 CompactDB() 代码中的缺陷。

如果定义了数据库的“AppTitle”属性（就像在数据库属性中定义“应用程序标题”时发生的情况一样），这会使显示的“默认窗口标题”逻辑无效，这可能导致脚本失败，或者“行为不可预测”。因此，添加代码来检查 AppTitle 属性 - 或使用 API 调用从 Application.hWndAccessApp 窗口读取窗口标题文本都可能更可靠。

此外，在 Access 2019 中，我们观察到： SendKeys "multi-key-string-here" ...也可能无法可靠地工作，需要替换为：

SendKey (single-character)

'put a DoEvents or Sleep 150 here

SendKey (single-character)

'put a DoEvents or Sleep 150 here

SendKey (single-character)

'put a DoEvents or Sleep 150 here

SendKey (single-character)

...从 Access UI 获得正确的响应。

也适用于 Access 2019：

Sendkeys "%yc"（

不再正确。

现在是：

Sendkeys "%y1c"

...如果这个小小的改变还不够 - 尝试确定（在代码中）如何区分 Access 2016 和 2019 - 祝你好运！因为 Application.Version 单独没有帮助，甚至结合 Application.Version 和 Application.Build 也不是保证（除非您处于受控发布的企业环境中，然后它可能会作为可能的版本/构建#s在流通应该更有限）。

【讨论】：

【解决方案6】：

是的，这很简单。

Sub CompactRepair()
  Dim control As Office.CommandBarControl
  Set control = CommandBars.FindControl( Id:=2071 )
  control.accDoDefaultAction
End Sub

基本上它只是以编程方式找到“压缩和修复”菜单项并单击它。

【讨论】：

我想我的版本和你的版本之间的区别在于，这个答案似乎适用于 Access 2007，而我的答案似乎适用于 Access 2003 及更低版本。
不喜欢虚拟点击命令栏 - 让我想起了 SendKeys！
我收到错误消息“您无法通过运行宏或 Visual Basic 代码来压缩打开的数据库。”

【解决方案7】：

我在 2003 年或可能是 97 年做了很多年，哎呀！

如果我记得您需要使用上面与计时器相关的子命令之一。 您无法在打开任何连接或表单的情况下对数据库进行操作。

因此，您需要关闭所有表单，并将计时器作为最后运行的方法启动。（一旦一切关闭，它又会调用紧凑操作）

如果您还没有弄清楚这一点，我可以翻阅我的档案并将其拉出来。

【讨论】：

【解决方案8】：

当用户退出 FE 尝试重命名后端 MDB 时，最好使用 yyyy-mm-dd 格式的名称中的今天日期。确保在执行此操作之前关闭所有绑定的表单，包括隐藏的表单和报告。如果您收到错误消息，哎呀，它很忙，所以不要打扰。如果成功，则将其压缩回去。

查看我的Backup, do you trust the users or sysadmins? 提示页面了解更多信息。

【讨论】：

【解决方案9】：

DBEngine.CompactDatabase 源，目标

【讨论】：

【解决方案10】：

Application.SetOption "Auto compact", False '（上面提到过）将此与按钮标题一起使用：“DB Not Compact On Close”

编写代码以使用“DB Compact On Close”切换标题连同 Application.SetOption "Auto compact", True

AutoCompact 可以通过按钮或代码设置，例如：导入大型临时表后。

启动表单可以包含关闭 Auto Compact 的代码，因此它不会每次都运行。

这样，您就不会试图与 Access 对抗。

【讨论】：

【解决方案11】：

如果您不想在关闭时使用 compact（例如，因为前端 mdb 是一个持续运行的机器人程序），并且您不想创建单独的 mdb 来进行压缩，请考虑使用cmd文件。

我让我的 robots.mdb 检查自己的大小：

FileLen(CurrentDb.Name))

如果它的大小超过 1 GB，它会创建一个像这样的 cmd 文件...

Dim f As Integer
Dim Folder As String
Dim Access As String
    'select Access in the correct PF directory (my robot.mdb runs in 32-bit MSAccess, on 32-bit and 64-bit machines)
    If Dir("C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE") > "" Then
        Access = """C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE"""
    Else
        Access = """C:\Program Files\Microsoft Office\Office\MSACCESS.EXE"""
    End If
    Folder = ExtractFileDir(CurrentDb.Name)
    f = FreeFile
    Open Folder & "comrep.cmd" For Output As f
    'wait until robot.mdb closes (ldb file is gone), then compact robot.mdb
    Print #f, ":checkldb1"
    Print #f, "if exist " & Folder & "robot.ldb goto checkldb1"
    Print #f, Access & " " & Folder & "robot.mdb /compact"
    'wait until the robot mdb closes, then start it
    Print #f, ":checkldb2"
    Print #f, "if exist " & Folder & "robot.ldb goto checkldb2"
    Print #f, Access & " " & Folder & "robot.mdb"
    Close f

... 启动 cmd 文件 ...

Shell ExtractFileDir(CurrentDb.Name) & "comrep.cmd"

...然后关闭...

DoCmd.Quit

接下来，cmd文件压缩并重启robot.mdb。

【讨论】：

糟糕，ExtractFileDir 不是标准的 VBA 函数... Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) 也可以解决问题。

【解决方案12】：

试试这个。它适用于代码所在的同一数据库。只需调用如下所示的 CompactDB() 函数。确保在添加函数后，在第一次运行之前单击 VBA 编辑器窗口中的保存按钮。我只在 Access 2010 中测试过。ba-da-bing，ba-da-boom。

Public Function CompactDB()

    Dim strWindowTitle As String

    On Error GoTo err_Handler

    strWindowTitle = Application.Name & " - " & Left(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4)
    strTempDir = Environ("Temp")
    strScriptPath = strTempDir & "\compact.vbs"
    strCmd = "wscript " & """" & strScriptPath & """"

    Open strScriptPath For Output As #1
    Print #1, "Set WshShell = WScript.CreateObject(""WScript.Shell"")"
    Print #1, "WScript.Sleep 1000"
    Print #1, "WshShell.AppActivate " & """" & strWindowTitle & """"
    Print #1, "WScript.Sleep 500"
    Print #1, "WshShell.SendKeys ""%yc"""
    Close #1

    Shell strCmd, vbHide
    Exit Function

    err_Handler:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Close #1

End Function

【讨论】：

【解决方案13】：

请注意以下几点 - 所有喜欢为 MS-Access 执行“关闭时压缩”解决方案的人。

我以前也更喜欢这个选项，直到有一天，我在压缩和修复操作期间收到可能来自 DBEngine 的最糟糕的错误消息：

“表 MSysObjects 已损坏 - 表被截断。”

现在，您可能从未意识到甚至可能出现这种错误。

嗯，是的。如果您看到它，您的整个数据库以及其中的所有内容现在都已经消失了。噗！

有趣的是，Access 会让你真正重新打开“固定”数据库，只是，Access 窗口和菜单项现在都完全没用了（除了关闭数据库并再次退出访问），因为所有表（包括其他 MSYS* 表、表单、查询、报告、代码模块和宏）完全消失了 - 并且先前分配给它们的磁盘空间已释放给 Windows 操作系统的招标 - 除非您有额外的保护而不是沼泽标准回收站，对你也无济于事。

所以，如果您真的想接受 Compact on Close 完全破坏您的数据库的风险 - 无法恢复它，那么请...继续。

如果 OTOH，像我一样，您发现这种风险是不可接受的，那么，请不要再启用 C&R-on-Close。

【讨论】：

【解决方案14】：

查看此解决方案VBA Compact Current Database。

基本上它说这应该可以工作

Public Sub CompactDB() 
    CommandBars("Menu Bar").Controls("Tools").Controls ("Database utilities"). _
    Controls("Compact and repair database...").accDoDefaultAction 
End Sub

【讨论】：

我强烈建议使用直接 VBA 方法。

【解决方案15】：

还有 Michael Kaplan 的 SOON ("Shut One, Open New") add-in。你必须把它锁起来，但这是一种方法。

我不能说我有太多的理由想要以编程方式执行此操作，因为我正在为最终用户编程，而且他们从不使用 Access 用户界面中的前端以外的任何东西，而且没有有理由定期压缩设计合理的前端。

【讨论】：

不错的战略思想。但有时，您只是希望它是一个独立的文件。便携式工具。
高度怀疑：“没有理由定期压缩设计合理的前端。”首先，前端没有被压缩；其次，即使在“设计合理的前端”上也绝对应该进行压缩和修复，因为内部访问碎片并不总是前端存在某种设计缺陷的结果。