主页 / dba / 问题 / 193134
Accepted
ConanTheGerbil
Asked: 2017-12-15 06:03:35 +0800 CST

如何从 VBA 函数压缩当前的 MS Access 数据库

  • 772

我希望能够从数据库的 VBA 模块中运行“压缩和修复”过程。

我有一个偶尔运行的批处理，它删除一些旧表，从其他数据库重新导入它们，重命名几个字段，进行一些更新并进行一些其他小的更改。这个过程不是火箭科学，但有几个步骤，所以它确实需要自动化。

问题是几个步骤（更新）会暂时增加数据库的大小，这可能会导致后续导入出现问题。

如果我手动执行该过程（包括压缩），那么一切正常，我最终得到一个 800MByte 的数据库。如果我使用我的自动 VBA 脚本（没有压缩），那么当数据库超过 2GB 限制时，它会在中途崩溃。

我在这个主题上找到了几个线程，但它们都是 3 到 4 岁（或更多），他们描述的方法似乎不再起作用。

它们是适用于 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

其中

ms-access vba

2 个回答

  1. Best Answer

    这根本不可能。压缩和修复数据库需要关闭数据库。因此，您不能在子或过程中的步骤之间压缩和修复数据库，因为在运行过程时数据库是打开的。

    您可能会注意到功能区上的压缩和修复按钮需要排他锁，关闭数据库，然后压缩和修复，然后重新打开它。

    我的建议：从外部数据库、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 文件的防病毒/策略之类的东西可能会破坏这种方法。

    • 4

  2. 这是 VBA 代码，我已经尝试并工作过，从 Excel 运行；

    Sub CompactAndRepairAccessDB()

    Dim Acc As Object
    Set Acc = CreateObject("access.application")

    Dim dbPath As String, dbPathX As String
    dbPath = Application.ThisWorkbook.Path & "\" & "YourDatabaseNameHere.accdb"
    dbPathX = Application.ThisWorkbook.Path & "\" & "tmp.accdb"

    Acc.DBEngine.CompactDatabase dbPath, dbPathX
    Acc.Quit
    Set Acc = Nothing
    Kill dbPath
    Name dbPathX As dbPath

End Sub

    在此链接中找到了解决方案并稍作修改。

    http://www.vbaexpress.com/forum/showthread.php?9262-Solved-VBA-Compact-and-Repair

    • 0

相关问题