Архиваторы - Модуль работы с архиватором WinRAR или 7-Zip (+ пример)

Ещё потребуется два дополнительных модуля:   
    - modExecCmd - Запуск процесса и ожидание его окончания (см. ниже)
    и
    - modFoldersAndFiles - Модуль для работы с папками файлами (см. ниже)

Пример использования:

Private Sub Test_modArchiv()
'es - 20.10.2012
'--------------------------------------------------------------------
'Сразу назначаем архиватор:
Const sArhiverPath As String = "C:\Program Files\WinRAR\WinRAR.exe" 'Путь к архиватору
'--------------------------------------------------------------------
Dim sPathSRS As String     'Путь к исходному файлу
Dim sPathDST As String     'Путь к (создаваемому - пополняемому) архиву
Dim l As Long              'Результ выполнения операции (должно быть = 0)

'Создаём архив и добавляем в него первый файл
On Error GoTo Test_modArchiv_Err
    sPathSRS = CurrentProject.Path & "\Читать!.txt"            ' что ...
    sPathDST = CurrentProject.Path & "\Test_01\Test_modArchiv" ' куда ...
    l = DBToArchive(sArhiverPath, sPathSRS, sPathDST)
    If l > 0 Then
        ' ... Обработка ошибки (Сообщение функция выдаёт сама)
    End If
'Добавляем в тот же архив файл базы данных с предварительным сжатием
    sPathSRS = CurrentProject.Path & "\MoneyDB.mdb"            ' что ...
    sPathDST = CurrentProject.Path & "\Test_01\Test_modArchiv" ' куда ...
    l = DBToArchive(sArhiverPath, sPathSRS, sPathDST, True)
    If l > 0 Then
        ' ... Обработка ошибки (Сообщение функция выдаёт сама)
    End If

'Итак архив: ... "\Test_01\Test_modArchiv.zip" содержит уже 2 файла

' ... извлекаем один из них ("MoneyDB.mdb") в подпапку Test_02
    ' откуда ...
    sPathSRS = CurrentProject.Path & "\Test_01\Test_modArchiv.zip"
    ' куда ... (причём подпапка Test_02 - создаёться автоматом)
    sPathDST = CurrentProject.Path & "\Test_02"
    l = DBFromArchive(sArhiverPath, sPathSRS, sPathDST, "MoneyDB.mdb")
    If l > 0 Then
        ' ... Обработка ошибки (Сообщение функция выдаёт сама)
    End If

'... а теперь извлекаем ВСЕ файлы в подпапку Test_03
    ' откуда ...
    sPathSRS = CurrentProject.Path & "\Test_01\Test_modArchiv.zip"
    ' куда ... (причём подпапка Test_03 - создаёться автоматом)
    sPathDST = CurrentProject.Path & "\Test_03"
    l = DBFromArchive(sArhiverPath, sPathSRS, sPathDST)
    If l > 0 Then
        ' ... Обработка ошибки (Сообщение функция выдаёт сама)
    End If


Test_modArchiv_Bye:
    Exit Sub

Test_modArchiv_Err:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in procedure Test_modArchiv", vbCritical, "Error!"
    Resume Test_modArchiv_Bye
    
End Sub

Модуль работы с архиватором:

'--------------------------------------------------------------------
' Module    : modArchiv
' Author    : es
' Date      : 02.02.2011
' Purpose   : Модуль для работы с архиваторам WinRAR или 7-Zip (можно дописать любой другой)
'             Внимание!
'             Использует модули :
'             modExecCmd = Запуск процесса и ожидание его окончания - Функция: ExecCmd
'             modFoldersAndFiles = Модуль для работы с папками файлами
'                                - Функции: PrepareFolders и FileIsFree
'             (названия модулей значения не имеют и могут быть произвольными)
'--------------------------------------------------------------------
Option Compare Database
Option Explicit

Public Function DBToArchive(sArchiverPath As String, strDBPath As String, _
                            strArcPath As String, _
                            Optional blCompactBefore As Boolean = False) As Long
'Создает архив ZIP по аргументам:
'   sArchiverPath    - путь к Архиватору
'   strDBPath        - путь к исходной базе (Что) - или путь к произвольному файлу
'   strArcPath       - путь к создаваемому архиву (Куда)
'   blCompactBefore  - сжать базу перед помещением в архив (опционально - по умолчанию = НЕТ)
'Причём: Архиватор определяеться по исполняемому файлу - автоматом из аргумента sArchiverPath
'--------------------------------------------------------------------
'Команды и ключи архивации WinRAR = "a -m4 -afzip -ep -t -ibck -inul"
'a        - добавить в архив
'-m4      - выбрать метод сжатия = 4 (Хороший метод сжатия)
'-afzip   - создать архив в формате ZIP
'-ep      - исключить пути из имен
'-t       - протестировать файлы после архивирования
'-ibck    - запустить WinRAR как фоновый процесс в системном лотке
'-o+      - перезаписывать существующие файлы
'-inul    - не выводить сообщения об ошибках
'e        - извлечь из архива, игнорируя пути
'--------------------------------------------------------------------
'Команды и ключи архивации 7-Zip = "a -tzip"
'a        - добавить в архив
'-tzip    - создание архива в формате ZIP

'--------------------------------------------------------------------
Dim sParam As String
Dim sArchName As String


Dim i As Long
Dim str As String
Dim strDistFolder As String
Dim strCompactedDB As String

On Error GoTo DBToArchive_Error
    
'Проверка путей указанных в аргументах ("защита от дурака")
    '01  - проверяем архиватор
    If Dir(sArchiverPath) = "" Then
        MsgBox "Не могу найти исполняемый файл архиватора:" & vbCrLf & _
        sArchiverPath, vbCritical, "Нет Архиватора"
        GoTo DBToArchive_Bye
    End If
    
    '02 - Проверка наличия указанного в аргументе исходного файла
    If Dir(strDBPath, vbNormal) = "" Then
        MsgBox "Не могу найти исходный файл для помещения в архив:" & vbCrLf & _
        strDBPath, vbCritical, "Нет исходного файла!"
        Exit Function
    End If

'Определяемся - с каким архиватором имем дело
    str = LCase(Right(sArchiverPath, 7)) 'Берём 7 правых символов из пути к архиватору и опредерям с чем имеем дело
    Select Case str
        Case "rar.exe" '= WinRAR
            sArchName = "WinRAR"
            sParam = "a -m4 -afzip -ep -t -ibck -inul"        'Команды и ключи архивации
        
        Case "7zg.exe" '= 7-Zip
            sArchName = "7-Zip"
            sParam = "a -tzip"        'Команды и ключи архивации
        
        Case Else
            MsgBox "Не могу определить используемый архиватор:" & vbCrLf & sArchiverPath, vbCritical, "Нет Архиватора"
            GoTo DBToArchive_Bye
    End Select
    
'Проверка что исходный файл не открыт другим процессом
    If FileIsFree(strDBPath) = False Then
        MsgBox "Исходный файл:" & vbCrLf & _
        strDBPath & vbCrLf & _
        "- занят другим процессом или пользователем, архивация невозможна!", vbCritical, "Файл занят"
            GoTo DBToArchive_Bye
    End If


'Проверка пути архивации
    i = PrepareFolders(strArcPath)
    If i > 0 Then Err.Raise i
    
'--------------------------------------------------------------------
'Проверяем необходимость сжатия базы
    If blCompactBefore = False Then GoTo StartArchivator

'--------------------------------------------------------------------
'Сжатие исходного файла базы
    'Установка папки для сжатого файла БД по пути к исходному
    For i = Len(strDBPath) To 1 Step -1
        If Mid(strDBPath, i, 1) = "\" Then
            strDistFolder = Mid(strDBPath, 1, i)
            Exit For
        End If
    Next i
    
    'Ищем свободный номер временного файла - вида "db001.mdb"...
    For i = 1 To 999
        str = strDistFolder & "db" & Format(i, "000") & ".mdb"
        If Dir(str, vbNormal) = "" Then
            strCompactedDB = str
            Exit For
        End If
    Next i
    
    'Сжатие исходной во временную
    DBEngine.CompactDatabase strDBPath, strCompactedDB
    DoEvents

    'Замена исходной базы её сжатой копией
    FileCopy strCompactedDB, strDBPath
    DoEvents

    'Удаление сжатой копии
    Kill strCompactedDB

StartArchivator: 'Запуск архиватора = Создание Архива
'--------------------------------------------------------------------
'Строим команду архиватору
    str = """" & sArchiverPath & """ " & sParam & " """ & strArcPath & """ """ & strDBPath & """"
    'Debug.Print str:  Exit Function

'Запускаем архиватор и ждем пока закончит работать
    DBToArchive = ExecCmd(str)

'Анализ того как все прошло
    If DBToArchive > 0 Then
        str = ArcErrDescription(DBToArchive, sArchName) 'см. функцию ниже (ArcErrDescription)
        MsgBox "При создании архива:" & vbCrLf & _
                strArcPath & vbCrLf & _
                "Архиватор вернул ошибку:" & vbCrLf & _
                str, vbCritical, "Ошибка Архиватора"
    End If

DBToArchive_Bye:
    Exit Function

DBToArchive_Error:
    Select Case Err.Number
        Case 52
            MsgBox "Ошибка доступа к Архиву:" & vbCrLf & _
            strArcPath, vbCritical
        Case 3356
            MsgBox "Файл базы данных:" & vbCrLf & _
            strDBPath & vbCrLf & _
            "Занят другим пользователем!", vbCritical, "Ошибка доступа"
        Case Else
            MsgBox "Произошла Ошибка №" & Err.Number & vbCrLf & _
            "(" & Err.Description & ")" & vbCrLf & _
            "В Процедуре Архивирования"
    End Select
    DBToArchive = Err.Number
    Resume DBToArchive_Bye
End Function

Public Function DBFromArchive(strArchPath As String, strArcPath As String, strToFolder As String, _
        Optional strFileName = "*.*") As Long
'Извлекает файлы из архива по аргументам:
'   sArchiverPath    - путь к Архиватору
'   strArcPath       - путь к архиву
'   strToFolder      - папка для извлечения (Куда) (при отсутствии создается автоматом)
'   strFileName      - Имя извлекаемого файла (если нужны не все)
'--------------------------------------------------------------------
'7-Zip Param = -aoa = Overwrite All existing files without prompt.
'--------------------------------------------------------------------

Dim str As String
Dim sArchName As String
Dim sParam As String                      'Команды и ключи РазАрхивации
Dim sParam2 As String                      'Команды и ключи РазАрхивации

On Error GoTo DBFromArchive_Error
    DBFromArchive = 70

    str = LCase(Right(strArchPath, 7))
    Select Case str
        Case "rar.exe" '= WinRAR
            sArchName = "WinRAR"
            sParam = "e -ibck -o+ -inul"         'Команды и ключи РазАрхивации
        
        Case "7zg.exe" '= 7-Zip
            sArchName = "7-Zip"
            sParam = "e"
            sParam2 = "-aoa"                          'Команды и ключи РазАрхивации
        
        Case Else
            MsgBox "Не могу определить используемый архиватор:" & vbCrLf & strArchPath, vbCritical, "Нет Архиватора"
            Exit Function
    End Select
    
'Проверка наличия указанного в аргументе исходного файла
    If Dir(strArcPath, vbNormal) = "" Then
        MsgBox "Не могу найти исходный файл архива:" & vbCrLf & _
        strArcPath, vbCritical, "Нет файла архива"
        Exit Function
    End If

'Проверка наличия устройства извлечения по папке
    str = Dir(Mid(strToFolder, 1, 3), vbDirectory)

'Проверка наличия слеша в конце пути к папке извлечения
    If Mid(strToFolder, Len(strToFolder), 1) <> "\" Then strToFolder = strToFolder & "\"
    
'Строим команду архиватору
    Select Case sArchName
        Case "WinRAR"
            str = """" & strArchPath & """ " & sParam & _
                " """ & strArcPath & """ """ & strFileName & """ """ & strToFolder & """"
        Case "7-Zip"
             
    End Select
'Запускаем архиватор и ждем пока закончит работать
    DBFromArchive = ExecCmd(str)

'Анализ того как все прошло
    If DBFromArchive > 0 Then
        str = ArcErrDescription(DBFromArchive, sArchName)
        MsgBox "При обработке архива:" & vbCrLf & strArcPath & vbCrLf & _
        "Архиватор вернул ошибку:" & vbCrLf & str, vbCritical, "Ошибка архиватора"
    End If

DBFromArchive_Bye:
    On Error Resume Next
    Exit Function

DBFromArchive_Error:
    Select Case Err.Number
    Case 52
        MsgBox "Ошибка доступа к папке извлечения файлов!" & vbCrLf & _
        strToFolder, vbCritical
    Case Else
        MsgBox "Произошла Ошибка №" & Err.Number & vbCrLf & _
        "(" & Err.Description & ")" & vbCrLf & _
        "В Процедуре: DBFromArchive из: Module modArchives"
    End Select
    DBFromArchive = Err.Number
    Err.Clear
    Resume DBFromArchive_Bye
End Function

Private Function ArcErrDescription(intErr As Long, AName As String) As String
'Возвращает строку = Расшифровка кодов ошибок возвращаемых архиваторами
'--------------------------------------------------------------------
On Error GoTo ArcErrDescription_Error
    
    Select Case AName
    Case "WinRAR"
        Select Case intErr
            Case 1:    ArcErrDescription = "Предупреждение. Произошли некритические ошибки."
            Case 2:    ArcErrDescription = "Произошла критическая ошибка."
            Case 3:    ArcErrDescription = "При распаковке обнаружена ошибка CRC."
            Case 4:    ArcErrDescription = "Предпринята попытка изменить заблокированный архив."
            Case 5:    ArcErrDescription = "Произошла ошибка записи на диск."
            Case 6:    ArcErrDescription = "Произошла ошибка открытия файла."
            Case 7:    ArcErrDescription = "Ошибка при указании параметра в командной строке."
            Case 8:    ArcErrDescription = "Недостаточно памяти для выполнения операции."
            Case 9:    ArcErrDescription = "Ошибка при создании файла."
            Case 255:  ArcErrDescription = "Операция была прервана пользователем."
            Case Else: ArcErrDescription = "Неизвестная ошибка"
        End Select
     Case "7-Zip"
        Select Case intErr
            Case 0:     ArcErrDescription = "No Error"
            Case 1:     ArcErrDescription = "Warning (Non fatal error(s)). For example, one or more files were locked by some other application, so they were not compressed."
            Case 2:     ArcErrDescription = "Fatal Error"
            Case 7:     ArcErrDescription = "Command line error"
            Case 8:     ArcErrDescription = "Not enough memory for operation"
            Case 255:     ArcErrDescription = "User stopped the process"
        End Select
    Case Else
        ArcErrDescription = "Error !!!"
    End Select
    
ArcErrDescription_Bye:
    Exit Function
ArcErrDescription_Error:
    ArcErrDescription = "Неизвестная ошибка"
    Err.Clear
    Resume ArcErrDescription_Bye
End Function

Модуль - modExecCmd = Запуск процесса и ожидание его окончания

Option Compare Database
Option Explicit
'--------------------------------------------------------------------
' Module    : modExecCmd
' Author    : es
' Date      : 20.01.04
' Purpose   : Запуск процесса и ожидание его окончания
'--------------------------------------------------------------------
'API функции на тему ExecCmd с небольшой правкой взяты из
'MSDN ID:Q129796
'--------------------------------------------------------------------
Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
   hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As String, ByVal lpCommandLine As String, ByVal _
   lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _
   lpStartupInfo As STARTUPINFO, lpProcessInformation As _
   PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32" _
   (ByVal hObject As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
   (ByVal hProcess As Long, lpExitCode As Long) As Long

Private Const STARTF_USESHOWWINDOW& = &H1
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
'--------------------------------------------------------------------
Public Function ExecCmd(cmdline$, Optional WindowStyle& = 4) As Long
'es 20.01.04
'--------------------------------------------------------------------
'Опции по WindowStyle$:
'   0 - Window is hidden and focus is passed to the hidden window.
'   1 - Window has focus and is restored to its original size and position.
'   2 - Window is displayed as an icon with focus.
'   3 - Window is maximized with focus.
'   4* - Window is restored to its most recent size and position. The currently active window remains active.
'   6 - Window is displayed as an icon. The currently active window remains active.
'--------------------------------------------------------------------
Dim proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ret As Long
' Initialize the STARTUPINFO structure:
    With start
        .cb = Len(start)
        .dwFlags = STARTF_USESHOWWINDOW
        .wShowWindow = WindowStyle
    End With

' Start the shelled application:
    ret = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _
    NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)

' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, INFINITE)
    Call GetExitCodeProcess(proc.hProcess, ret&)
    Call CloseHandle(proc.hThread)
    Call CloseHandle(proc.hProcess)
    ExecCmd = ret
End Function

Необходимые функции из модуля - modFoldersAndFiles (работа с папками и файлами)

Public Function PrepareFolders(strFilePath As String) As Long
'es 20.01.04
'Проверка на наличие и создание папок произвольной вложенности перед
'копированием, перемещением или созданием файла
'В случае возникновения ошибки возвращает ее код
'--------------------------------------------------------------------
Dim i As Integer
Dim x As Integer
Dim strTemp As String
Dim curPath As String
On Error GoTo PrepareFoldersErr
    x = Len(strFilePath)
    For i = 1 To x
        If Mid(strFilePath, i, 1) = "\" Then
            curPath = Mid(strFilePath, 1, i - 1)
            If Dir(curPath, vbDirectory) = "" Then
                MkDir curPath
            End If
        End If
    Next i
    Exit Function
PrepareFoldersErr:
    PrepareFolders = Err.Number
    Err.Clear
End Function

Public Function FileIsFree(strPath) As Boolean
'es 28.10.05
'Проверяет не открыт ли файл другим процессом (пользователем)
'Если НЕТ - возвращает TRUE (файл доступен для монопольного доступа)
'--------------------------------------------------------------------
Dim varFile As Variant
On Error GoTo FileIsFree_Error
    varFile = FreeFile
    Open strPath For Input Access Read Lock Read Write As varFile Len = 1
    FileIsFree = True
FileIsFree_Bye:
    On Error Resume Next
    Close varFile
    Exit Function
FileIsFree_Error:
    Err.Clear
    FileIsFree = False
    Resume FileIsFree_Bye
End Function

Файл примера для тестирования и просмотра прилагается  (MSA 2003 - 46Kb)

Отработает сразу если у Вас путь "C:\Program Files\WinRAR\WinRAR.exe" - существует, иначе нужно менять код ...

    01. Запустить "modArchivTestDB MSA2003 vXXX.mdb"
    02. Смотреть в модуле "mod00-Test" - "Private Sub Test_modArchiv()"

MSA-2003 ( 45 kB)