Сжатие внешней базы данных

Private Sub CompactExternalDB_Demo()
Dim lRet&, sVal$
    sVal = "d:\Temp\modArchivTestDB MSA2003\MoneyDB_SM.mdb"
    lRet = CompactExternalDB(sVal)
    If Not lRet = 0 Then 'ошибка при сжатии
        ' ... действия ...
    End If
End Sub

Функция:

Private Function CompactExternalDB(sDBFilePath As String, Optional blnNoReportMSG As Boolean) As Long
' Сжатие внешней (не текущей) БД средствами MS Access - возвращает 0 или код ошибки
' s0000547 - 04.02.2024 v003
' -------------------------------------------------------------------------------------------------/
' Аргументы:
'   sDBFilePath     = Полный путь к сжимаемой БД
'   blnNoReportMSG  = Опционально - НЕ показывать сообщение с отчётом при успешном завершении
' -------------------------------------------------------------------------------------------------/
Dim sTempFilePath$, cVal@, iVal%, sVal$
Dim sDBFileName$, sDBFileExt$, sDBFolderPath$, lSizeBefore As Long, iSizeAfter As Long
Dim objFSO As Object  'Обьект FSO (File System Object) для копирования и прочего
Dim objFSOFile As Object
Const csMsgBoxTitle$ = "Сжатие БД"          ' Заголовок сообщений
Const csTempFilePrefix$ = "Temp_"           ' Префикс имени временного файла
' -------------------------------------------------------------------------------------------------/
On Error GoTo CompactExternalDB_Err
'Проверка пути (для начала)
    If Dir(sDBFilePath) = "" Then
        MsgBox "Файл данных:" & vbCrLf & """" & sDBFilePath & """" & vbCrLf & _
            "Не существует." & vbCrLf & "Прдолжение не возможно", vbExclamation, csMsgBoxTitle
        GoTo CompactExternalDB_End
    End If

'Проверка не открыт ли файл БД другим процессом - если ДА: Error 70 (Permission denied)
    iVal = FreeFile
    Open sDBFilePath For Random Access Read Write Lock Read Write As #iVal
    Close #iVal
     
'Создание объектов FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFSOFile = objFSO.GetFile(sDBFilePath)
    lSizeBefore = objFSOFile.Size 'Размер в байтах перед сжатием
    
' Генерация пути к временной БД:
    sDBFileExt = "." & objFSO.GetExtensionName(sDBFilePath)   'Расширение файла БД (уже с точкой в начале)
    sDBFolderPath = objFSOFile.ParentFolder.Path 'Путь к папке с БД:
' Путь к временной БД:
    sTempFilePath = sDBFolderPath & csTempFilePrefix & Format(Now, "yyyymmdd_hhnnss") & sDBFileExt
    'Debug.Print sTempFilePath
    
' Удаление временного файла(ов) по маске - если что очталось после прошлого раза)
    sVal = sDBFolderPath & "\Temp_" & Format(Now, "yyyy") & "*" & sDBFileExt
    If objFSO.FileExists(sVal) Then objFSO.DeleteFile sVal

' Сжатие во временный файл:
    DBEngine.CompactDatabase sDBFilePath, sTempFilePath
    DoEvents

' Копирование сжатой времееной БД в исходную : Что, Куда ... c перезаписью
    objFSO.CopyFile sTempFilePath, sDBFilePath, True
    DoEvents
    objFSO.DeleteFile sTempFilePath ' Удаление временного файла (опционально - пусть копия будет!)
    
' Отчёт:
    If blnNoReportMSG = False Then
        iSizeAfter = objFSOFile.Size 'Размер в байтах после сжатия
        cVal = (iSizeAfter - lSizeBefore) / 1024 'Разница в Kb
        If cVal > 1024 Then 'мег и больше
            sVal = Format(cVal / 1024, "# ##0.00") & " Mb"
        Else
            sVal = Format(cVal, "# ##0.00") & " Kb"
        End If
        sVal = "База данных:" & vbCrLf & """" & sDBFilePath & """" & vbCrLf & _
            "Успешно сжата." & vbCrLf & "Изменение размера: " & sVal
        MsgBox sVal, vbInformation, csMsgBoxTitle
    End If

' -------------------------------------------------------------------------------------------------/
CompactExternalDB_End:
    On Error Resume Next
    Close #iVal
    Set objFSO = Nothing: Set objFSOFile = Nothing
    Err.Clear
    Exit Function

CompactExternalDB_Err:
    Select Case Err.Number
        Case 70 ' DB File = Permission denied
            MsgBox "База данных:" & vbCrLf & """" & sDBFilePath & """" & vbCrLf & "Открыта другим процессом." & vbCrLf & _
                "Прдолжение не возможно", vbExclamation, csMsgBoxTitle
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function :" & _
                "CompactExternalDB.", vbCritical, "Error! " & csMsgBoxTitle
    End Select
    Err.Clear
    Resume CompactExternalDB_End
End Function