如何從 VBA 函式壓縮目前的 MS Access 數據庫

我希望能夠從數據庫的 VBA 模組中執行“壓縮和修復”過程。

我有一個偶爾執行的批處理過程，它刪除一些舊表，從其他數據庫重新導入它們，重命名幾個欄位，進行一些更新並進行一些其他小的更改。這個過程不是火箭科學，但有幾個步驟，所以它確實需要自動化。

問題是幾個步驟（更新）會暫時增加數據庫的大小，這可能會導致後續導入出現問題。

如果我手動執行該過程（包括壓縮），那麼一切正常，我最終得到一個 800MByte 的數據庫。如果我使用我的自動 VBA 腳本（沒有壓縮），那麼當數據庫超過 2GB 限制時，它會在中途崩潰。

我在這個主題上找到了幾個執行緒，但它們都是三四歲（或更多），他們描述的方法似乎不再起作用。

它們是適用於 Office 365（版本 1720）的任何解決方案嗎？

“自動壓縮”導致數據庫在關閉時壓縮，它不允許在步驟之間添加數據庫的壓縮。

我試過這個：

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

還有這個：

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

還有這個….

Public Sub CompactDb3()
   Application.SetOption "Auto compact", True
End Sub

其中

這根本不可能。壓縮和修復數據庫需要關閉數據庫。因此，您不能在子或過程中的步驟之間壓縮和修復數據庫，因為在執行過程時數據庫是打開的。

您可能會注意到功能區上的壓縮和修復按鈕需要排他鎖，關閉數據庫，然後壓縮和修復，然後重新打開它。

我的建議：從外部數據庫、VBScript 文件或 PowerShell 執行程序。執行批處理的第一部分，關閉文件，壓縮並修復，重新打開，執行第二部分

範常式式碼

Dim fileLocation As String
DBEngine.CompactDatabase fileLocation, fileLocation & "_1"
Kill fileLocation
Name fileLocation & "_1" As fileLocation

您可能還會注意到 Access compact 和 repair 按鈕在做類似的事情。如果您執行壓縮和修復，它會將數據移動到目前文件夾中名為Database.accdb的數據庫中（名稱可能因現有名稱/數據庫類型而異），然後刪除您目前的數據庫，然後重命名新數據庫。

---

好吧，但沒有什麼是不可能的，對吧？

好吧，有些事情是，但這不是其中之一，如果你願意做一些奇怪的詭計。正如我剛才所說，主要問題是必須關閉目前數據庫。因此，解決方法執行以下操作：

1. 以程式方式創建 VBScript 文件
2. 將程式碼添加到該文件，以便我們可以在不打開數據庫的情況下壓縮和修復我們的數據庫
3. 非同步打開並執行該文件
4. 在壓縮和修復發生之前關閉我們的數據庫
5. 壓縮並修復數據庫（創建副本），刪除舊的，重命名副本
6. 重新打開我們的數據庫，繼續批處理
7. 刪除新創建的文件

幸運的是，我有一些空閒時間，所以我想出了以下解決方案：

Public Sub CompactRepairViaExternalScript()
   Dim vbscrPath As String
   vbscrPath = CurrentProject.Path & "\CRHelper.vbs"
   If Dir(CurrentProject.Path & "\CRHelper.vbs") <> "" Then
       Kill CurrentProject.Path & "\CRHelper.vbs"
   End If
   Dim vbStr As String
   vbStr = "dbName = """ & CurrentProject.FullName & """" & vbCrLf & _
   "resumeFunction = ""ResumeBatch""" & vbCrLf & _
   "Set app = CreateObject(""Access.Application"")" & vbCrLf & _
   "Set dbe = app.DBEngine" & vbCrLf & _
   "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf & _
   "On Error Resume Next" & vbCrLf & _
   "Do" & vbCrLf & _
   "If Err.Number <> 0 Then Err.Clear" & vbCrLf & _
   "WScript.Sleep 500" & vbCrLf & _
   "dbe.CompactDatabase dbName, dbName & ""_1""" & vbCrLf & _
   "errCount = errCount + 1" & vbCrLf & _
   "Loop While err.Number <> 0 And errCount < 100" & vbCrLf & _
   "If errCount < 100 Then" & vbCrLf & _
   "objFSO.DeleteFile dbName" & vbCrLf & _
   "objFSO.MoveFile dbName & ""_1"", dbName" & vbCrLf & _
   "app.OpenCurrentDatabase dbName" & vbCrLf & _
   "app.UserControl = True" & vbCrLf & _
   "app.Run resumeFunction" & vbCrLf & _
   "End If" & vbCrLf & _
   "objFSO.DeleteFile Wscript.ScriptFullName" & vbCrLf
   Dim fileHandle As Long
   fileHandle = FreeFile
   Open vbscrPath For Output As #fileHandle
   Print #fileHandle, vbStr
   Close #fileHandle
   Dim wsh As Object
   Set wsh = CreateObject("WScript.Shell")
   wsh.Run """" & vbscrPath & """"
   Set wsh = Nothing
   Application.Quit
End Sub

這將完成上述所有步驟，並通過呼叫呼叫該ResumeBatch函式的數據庫上的函式來恢復批處理（不帶任何參數）。請注意，點擊執行保護和不喜歡 vbscript 文件的防病毒/策略之類的東西可能會破壞這種方法。

引用自：https://dba.stackexchange.com/questions/193134