web-dev-qa-db-ja.com

VBA関数から現在のMS Accessデータベースを圧縮する方法

データベースのVBAモジュール内から「圧縮と修復」プロセスを実行できるようにしたい。

時々実行するバッチプロセスがあります。古いテーブルをいくつか削除し、他のデータベースからそれらを再インポートし、いくつかのフィールドの名前を変更し、いくつかの更新を行い、その他いくつかの小さな変更を行います。プロセスはロケット科学ではありませんが、いくつかのステップがあるため、自動化する必要があります。

問題は、いくつかの手順（UPDATE）により、一時的にデータベースのサイズが大きくなり、その後のインポートで問題が発生する可能性があることです。

プロセスを手動で（圧縮を含めて）実行すると、すべてが正常に機能し、最終的に800MByteのデータベースになります。自動化されたVBAスクリプトを（圧縮せずに）使用すると、データベースが2Gバイトの制限を超えると、途中でクラッシュします。

私はこの問題についていくつかのスレッドを見つけましたが、それらはすべて4歳のうち3歳（またはそれ以上）であり、それらが説明する方法はもう機能していないようです。

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-accessvba
3
ConanTheGerbil

これはまったく不可能です。データベースを圧縮して修復するには、データベースを閉じる必要があります。そのため、プロシージャの実行時にデータベースが開いているため、サブまたはプロシージャのステップ間でデータベースを圧縮および修復することはできません。

リボンのコンパクトおよび修復ボタンが排他ロックを要求し、データベースを閉じてから、圧縮および修復してから再度開くことに気付くでしょう。

私のアドバイス：外部データベース、VBScriptファイル、またはPowerShellからプロセスを実行します。バッチの最初の部分を実行し、ファイルを閉じ、圧縮して修復し、再度開き、2番目の部分を実行します

サンプルコード

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

Accessのコンパクトボタンと修復ボタンでも同様の処理が行われていることに気付くかもしれません。圧縮と修復を実行すると、データは現在のフォルダー内のDatabase.accdbという名前のデータベースに移動し（名前は既存の名前/データベースタイプによって異なる場合があります）、現在のデータベースを削除します。新しい名前を変更します。

まあ、でも不可能はありませんよね？

まあ、いくつかのことはありますが、もしあなたが奇妙なトリックをやる気があるなら、これはそれらの1つではありません。今言ったように、主な問題は現在のデータベースを閉じなければならないことです。したがって、回避策は次のことを行います。

  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
Erik A

これが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
Sacid Karacuha