Private Const MAX_PATH = 260
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Sub CompactJetDatabase(Location As String, _
Optional BackupOriginal As Boolean = True)
On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
'檢查資料庫檔案是否存在
If Len(Dir(Location)) Then
'如果需要備份就執行備份
If BackupOriginal = True Then
strBackupFile = GetTemporaryPath & "backup.mdb"
If Len(Dir(strBackupFile)) Then Kill strBackupFile
FileCopy Location, strBackupFile
End If
'建立臨時檔案名
strTempFile = GetTemporaryPath & "temp.mdb"
If Len(Dir(strTempFile)) Then Kill strTempFile
'通過DBEngine壓縮資料庫檔案
DBEngine.CompactDatabase Location, strTempFile
'删除原來的資料庫檔案
Kill Location
'拷貝剛剛壓縮過臨時資料庫檔案至原來位置
FileCopy strTempFile, Location
'删除臨時檔案
Kill strTempFile
Else
End If
CompactErr:
Exit Sub
End Sub
Public Function GetTemporaryPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetTempPath(MAX_PATH, strFolder)
If lngResult <> 0 Then
GetTemporaryPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetTemporaryPath = ""
End If
End Function