' Сжатие

Public Function AutoCompact()

With CommandBars.Add(, 1, , True)

.Controls.Add 1, 2071, , , True

.Visible = True

.Controls(1).SetFocus

DoEvents

SendKeys "~"

End With

End Function

'ФУНКЦИЯ СЖАТИЯ БД DAO-Методом'

' gflngCompactDatabase(...)'

'ВХОДНЫЕ ПАРАМЕТРЫ ФУНКЦИИ:'

' CompactingDBPathAndName - строковый параметр, задающий ПОЛНЫЙ ПУТЬ (путь + имя файла)'

' к сжимаемой БД.'

' BackupBeforeCompactDB - необязательный логический параметр, указывающий на'

' необходимость сделать перед сжатием резервную копию сжимаемой БД (резервная'

' копия выкладывается в файл с именем "ИмяСжимаемогоФайла_Backup"). При'

' отсутствии параметра резервное копирование не производится.'

'ВОЗВРАЩАЕМОЕ ФУНКЦИЕЙ ЗНАЧЕНИЕ:'

' = 0, если сжатие произведено;'

' = Номеру возникшей ошибки, если выполнить сжатие не удалось.'

'ОСОБЕННОСТИ:'

' Для выполнения процедуры сжатия автоматически создается временный файл'

' с именем "ПолныйПуть\ИмяСжимаемогоФайла_Temp".'

' Резервное копирование, выполнение которого определяется параметром "BackupBeforeCompactDB",'

' производится в файл с именем "ПолныйПуть\ИмяСжимаемогоФайла_Backup"), при'

' этом старая копия резерва перезаписывается новой (фактически удаляется).'

' В случае, если сжимаемая БД открыта, то файл БД не будет скопирован (соответствующая'

' ошибка появится в момент копирования БД).'

Public Function gflngCompactDatabase( _

CompactingDBPathAndName As String, _

Optional BackupBeforeCompactDB As Boolean = False) As Long

Dim strTempFile As String

On Error GoTo ErrHandler

'Формируем имя для временного ("принимающего") файла'

strTempFile = Left(CompactingDBPathAndName, (Len(CompactingDBPathAndName) - 4)) & _

"_Temp" & Right(CompactingDBPathAndName, 4)

'Создаем (если надо) резервную копию файла БД перед сжатием'

If BackupBeforeCompactDB = True _

Then FileCopy CompactingDBPathAndName, _

Left(CompactingDBPathAndName, (Len(CompactingDBPathAndName) - 4)) & _

"_Backup" & Right(CompactingDBPathAndName, 4)

'Сжимаем файл БД (с перезаписью сжатого файла в новый файл)'

DBEngine.CompactDatabase CompactingDBPathAndName, strTempFile, dbLangCyrillic

'Перезаписываем сжатый (временный файл) на место несжатого (старого файла)'

FileCopy strTempFile, CompactingDBPathAndName

'Удаляем временный файл'

Kill strTempFile

Exit Function

ErrHandler:

'обрабатываем возможные ошибки'

gflngCompactDatabase = Err.Number

Err.Clear: Exit Function

End Function