外部のmdbファイル（今作業しているファイルではなく）を圧縮/修復する場合：
Application.compactRepair sourecFile, destinationFile
使用しているデータベースを圧縮する場合：
Application.SetOption "Auto compact", True
この最後のケースでは、ファイルを閉じるときにアプリが圧縮されます。
私の意見：mdbファイルを圧縮/修復したいときに呼び出すことができる追加のMDB "compacter"ファイルに数行のコードを書くことは非常に便利です。 、したがって、ファイルの外部からメソッドを呼び出す必要があります。
それ以外の場合、デフォルトでは、Accessアプリの各メインモジュールでオートコンパクトがtrueに設定されます。
災害が発生した場合、新しいmdbファイルを作成し、バギーファイルからすべてのオブジェクトをインポートします。通常、インポートできない障害のあるオブジェクト（フォーム、モジュールなど）が見つかります。
このモジュールを追加してみてください。非常に簡単です。Accessを起動し、データベースを開いて、[閉じるときにコンパクト]オプションを[True]に設定してから終了します。
自動圧縮の構文：
acCompactRepair "C:\Folder\Database.accdb", True
デフォルトに戻すには*：
acCompactRepair "C:\Folder\Database.accdb", False
*必須ではありませんが、バックエンドデータベースが1 GBを超える場合、直接データベースにアクセスすると、やや面倒になり、終了するのに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
' [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
Access 2013の場合、次のことができます。
Sendkeys "%fic"
これは、キーボードでALT、F、I、Cを入力するのと同じです。
おそらく、バージョンごとに文字のシーケンスは異なりますが、「％」記号は「ALT」を意味するため、コード内に残してください。 Altキーを押したときに表示される文字に応じて、文字を変更する必要がある場合があります。
ユーザーがFEを終了すると、できればyyyy-mm-dd形式の名前の今日の日付を使用して、バックエンドMDBの名前を変更しようとします。これを行う前に、非表示フォームを含むすべてのバインドされたフォームとレポートを必ず閉じてください。エラーメッセージが表示されても、おっと、忙しいので気にしないでください。成功したら、圧縮して戻します。
詳細については、私の バックアップ、ユーザーまたはシステム管理者を信頼しますか？ ヒントページを参照してください。
これを試して。コードが存在する同じデータベースで動作します。以下に示す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
フロントエンドとバックエンドを備えたデータベースがある場合。フロントエンドのメインナビゲーションフォームのメインフォームで次のコードを使用できます。
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
はい、簡単です。
Sub CompactRepair()
Dim control As Office.CommandBarControl
Set control = CommandBars.FindControl( Id:=2071 )
control.accDoDefaultAction
End Sub
基本的に、プログラムで「コンパクトと修復」メニュー項目を見つけてクリックするだけです。
DBEngine.CompactDatabaseソース、dest
Application.SetOption "Auto compact"、False '（上記）ボタンキャプションでこれを使用： "DB Not Close on Close"
Application.SetOption "Auto compact"、Trueとともに "DB Compact On Close"でキャプションを切り替えるコードを記述します。True
AutoCompactは、ボタンまたはコードを使用して設定できます。例：大きな一時テーブルをインポートした後。
スタートアップフォームには、毎回実行されないように、Auto Compactをオフにするコードを含めることができます。
この方法では、Accessと戦うことはできません。
私はこれを何年も前に2003年、あるいは97年にやってみました。
思い出すと、タイマーに関連付けられた上記のサブコマンドのいずれかを使用する必要があります。 接続またはフォームを開いた状態でデータベースを操作することはできません。
そのため、すべてのフォームを閉じ、最後に実行する方法としてタイマーを開始することについて何かをします。 （すべてが閉じると、コンパクト操作が呼び出されます）
あなたがこれを理解していない場合、私は私のアーカイブを掘り下げ、それを引き上げることができます。
クローズ時にコンパクトを使用したくない場合（たとえば、フロントエンドmdbは継続的に実行されるロボットプログラムであるため）、圧縮のためだけに別のmdbを作成したくない場合は、cmdファイルの使用を検討してください。
Robot.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を圧縮して再起動します。