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

MS Access: how to compact current database in VBA

提问by Nick

Pretty simple question, I know.

很简单的问题，我知道。

回答by Philippe Grondier

If you want to compact/repair an external mdb file (not the one you are working in just now):

如果您想压缩/修复外部 mdb 文件（不是您现在正在使用的文件）：

Application.compactRepair sourecFile, destinationFile

If you want to compact the database you are working with:

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

Application.SetOption "Auto compact", True

In this last case, your app will be compacted when closing the file.

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

My opinion: writting a few lines of code in an extra MDB "compacter" file that you can call when you want to compact/repair an mdb file is very usefull: in most situations the file that needs to be compacted cannot be opened normally anymore, so you need to call the method from outside the file.

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

Otherwise, the autocompact shall by default be set to true in each main module of an Access app.

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

In case of a disaster, create a new mdb file and import all objects from the buggy file. You will usually find a faulty object (form, module, etc) that you will not be able to import.

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

回答by Rob

For Access 2013, you could just do

对于 Access 2013，您可以这样做

Sendkeys "%fic"

This is the same as typing ALT, F, I, C on your keyboard.

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

It's probably a different sequence of letters for different versions, but the "%" symbol means "ALT", so keep that in the code. you may just need to change the letters, depending on what letters appear when you press ALT

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

Letters that appear when pressing ALT in Access 2013

在 Access 2013 中按 ALT 时出现的字母

回答by baldmosher

Try adding this module, pretty simple, just launches Access, opens the database, sets the "Compact on Close" option to "True", then quits.

尝试添加此模块，非常简单，只需启动 Access，打开数据库，将“关闭时压缩”选项设置为“真”，然后退出。

Syntax to auto-compact:

自动压缩的语法：

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

To return to default*:

返回默认值*：

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

*not necessary, but if your back end database is >1GB this can be rather annoying when you go into it directly and it takes 2 minutes to quit!

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

EDIT: added option to recurse through all folders, I run this nightly to keep databases down to a minimum.

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

'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
'   [email protected]
'   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

回答by jdawgx

Try this. It works on the same database in which the code resides. Just call the CompactDB() function shown below. Make sure that after you add the function, you click the Save button in the VBA Editor window prior to running for the first time. I only tested it in Access 2010. Ba-da-bing, ba-da-boom.

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

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

回答by Dale

Yes it is simple to do.

是的，这很简单。

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

Basically it just finds the "Compact and repair" menuitem and clicks it, programatically.

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

回答by Tony Toews

When the user exits the FE attempt to rename the backend MDB preferably with todays date in the name in yyyy-mm-dd format. Ensure you close all bound forms, including hidden forms, and reports before doing this. If you get an error message, oops, its busy so don't bother. If it is successful then compact it back.

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

See my Backup, do you trust the users or sysadmins?tips page for more info.

看我的备份，你信任用户还是系统管理员？提示页面了解更多信息。

回答by user1467890

If you have the database with a front end and a back end. You can use the following code on the main form of your front end main navigation form:

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

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

回答by Nick

DBEngine.CompactDatabase source, dest

DBEngine.CompactDatabase 源，dest

回答by Eddie

I did this many years back on 2003 or possibly 97, yikes!

很多年前，我在 2003 年或可能在 97 年就这样做了，哎呀！

If I recall you need to use one of the subcommands above tied to a timer. You cannot operate on the db with any connections or forms open.

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

So you do something about closing all forms, and kick off the timer as the last running method. (which will in turn call the compact operation once everything closes)

所以你做一些关于关闭所有表单的事情，并启动计时器作为最后运行的方法。（一旦一切都关闭，它将依次调用紧凑操作）

If you haven't figured this out I could dig through my archives and pull it up.

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

回答by Mike T

Application.SetOption "Auto compact", False '(mentioned above) Use this with a button caption: "DB Not Compact On Close"

Application.SetOption "Auto compact", False '（上面提到的）使用这个按钮标题：“DB Not Compact On Close”

Write code to toggle the caption with "DB Compact On Close" along with Application.SetOption "Auto compact", True

编写代码以使用“DB Compact On Close”以及 Application.SetOption“Auto compact”、True 来切换标题

AutoCompact can be set by means of the button or by code, ex: after importing large temp tables.

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

The start up form can have code that turns off Auto Compact, so that it doesn't run every time.

启动窗体可以包含关闭自动压缩的代码，这样它就不会每次都运行。

This way, you are not trying to fight Access.

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