Архиваторы - Модуль работы с архиватором 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)