Архивация/Извлечение из архива через VBA

Option Explicit
Const sWinRarAppPath As String = "C:\Program Files\WinRAR\WinRAR.exe"

Sub CallRARFunction()
    'Архивируем папку "C:\Temp\Тест"
    If FolderToRAR("C:\Temp\Тест") Then
        MsgBox "Папка успешно заархивирована!", vbInformation, "www.excel-vba.ru" '
    End If
    'Архивируем файл C:\Temp\Test.xls
    If FileToRAR("C:\Temp\", "Test.xls", "Test.rar") Then
        MsgBox "Файл успешно заархивирован!", vbInformation, "www.excel-vba.ru" '
    End If
    'Извлекаем из архива "C:\Temp\Test" файлы в папку с архивом "C:\Temp\" '
    If UnRAR("C:\Temp\Test", "Test.rar") Then
        MsgBox "Файлы успешно распакованы!", vbInformation, "www.excel-vba.ru" '
    End If
End Sub

'---------------------------------------------------------------------------------------
' Procedure : FolderToRAR
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : Функция архивирует указанную папку
'             sPath       - путь к папке для архивации
'---------------------------------------------------------------------------------------
Function FolderToRAR(sPath As String)
    Dim sArhiveName As String
    Dim sWinRarApp As String
    sWinRarApp = sWinRarAppPath & " A -ep " '
    sArhiveName = sPath & ".rar" '
    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.
    'без кавычек пробелы недопустимы
    FolderToRAR = Shell(sWinRarApp & " """ & sArhiveName & """ """ & sPath & """ ", vbHide)
End Function

'---------------------------------------------------------------------------------------
' Procedure : FileToRAR
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : Функция архивирует указанный файл
'             sPath       - путь к файлу для архивации
'             sFileName   - имя файла для архивации
'             sArhiveName - имя результирующего архива
'---------------------------------------------------------------------------------------
Function FileToRAR(sPath As String, sFileName As String, ByVal sArhiveName As String)
    Dim sWinRarApp As String
    'архивируем файл с удалением самого файла после архивации(за это отвечает параметр -df )
    sWinRarApp = sWinRarAppPath & " A -ep -df "
    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.
    'без кавычек пробелы недопустимы
    FileToRAR = Shell(sWinRarApp & " """ & sPath & sArhiveName & """ """ & sPath & sFileName & """ ", vbHide)
End Function

'---------------------------------------------------------------------------------------
' Procedure : UnRAR
' Author    : The_Prist(Щербаков Дмитрий)
'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
'             http://www.excel-vba.ru
' Purpose   : Функция извлекает данные из указанного архива в папку с файлом архива
'             sPath       - путь к архиву
'             sArhiveName - имя архива
'---------------------------------------------------------------------------------------
Function UnRAR(sPath As String, sArhivName As String)
    Dim sWinRarApp As String
    'извлекаем данные из архива в скрытом окне(vbHide)
    'с перезаписью существующих файлов (-o+)
    sWinRarApp = sWinRarAppPath & " E -o+ "
    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.
    'без кавычек пробелы недопустимы
    UnRAR = Shell(sWinRarApp & " """ & sPath & "\" & sArhivName & """ """ & sPath & """ ", vbHide)
End Function

'---------------------------------------------------------------------------------------
' Procedure : CreateNewZip
' DateTime  : 03.08.2014 21:55
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Основная процедура создания пустого ZIP-архива
'---------------------------------------------------------------------------------------
Sub CreateNewZip(sPath As String)
    If Dir(sPath) <> "" Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ZIPOneFile
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Создание архива из одного файла или добавление в уже существующий архив нового файла
'             sZIPFileName - полный путь к файлу создаваемого архива
'             sFileToZIP - полный путь к файлу для архивации
'---------------------------------------------------------------------------------------
Function ZIPOneFile(sZIPFileName As String, sFileToZIP As String)
    Dim objShell As Object
    Dim lcnt As Long
 
    Set objShell = CreateObject("Shell.Application")
    'создаем пустой ZIP-архив, если его еще нет
    If Dir(sZIPFileName, 16) = "" Then
        CreateNewZip (sZIPFileName)
    End If
    lcnt = objShell.Namespace((sZIPFileName)).Items.Count
    'помещаем файлы из папки в архив
    objShell.Namespace((sZIPFileName)).CopyHere CStr(sFileToZIP)
    'дожидаемся окончания архивации
    Do Until objShell.Namespace((sZIPFileName)).Items.Count = lcnt + 1
        DoEvents
    Loop
End Function

Sub ToRarExample()
    Call ZIPOneFile("C:\Documents\Архив\Test.zip", "C:\Test.xls")
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Zip_File_Or_Files
' DateTime  : 03.08.2014 21:54
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Архивация выбранных файлов
'---------------------------------------------------------------------------------------
Sub Zip_File_Or_Files()
    Dim sDate As String, sZIPPath As String, sZIPFileName As String, sWBName As String
    Dim objShell As Object, lf As Long, lZIPCnt As Long
    Dim avFiles
 
    'Выбираем файл/файлы, которые необходимо поместить в архив
    'чтобы выбирать не только файлы Excel:"All Files (*.*), *.*"
    avFiles = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", , "Выбрать файлы для архивации", , True)
    If VarType(avFiles) = vbBoolean Then Exit Sub
    'создаем путь для создания архива(папка с выбранными файлами)
    sZIPPath = Replace(avFiles(1), Dir(avFiles(1), 16), "")
    If Right(sZIPPath, 1) <> "\" Then
        sZIPPath = sZIPPath & "\"
    End If
 
    sDate = Format(Now, " dd-mm-yy h-mm-ss")
    sZIPFileName = sZIPPath & "VBAZip " & sDate & ".zip"
    'создаем пустой ZIP-архив
    CreateNewZip (sZIPFileName)
    Set objShell = CreateObject("Shell.Application")
    lZIPCnt = 0
    For lf = LBound(avFiles) To UBound(avFiles)
        sWBName = Dir(avFiles(lf), 16)
        If IsBookOpen(sWBName) Then
            MsgBox "Невозможно поместить книгу '" & avFiles(lf) & "' в архив!" & vbNewLine & _
                   "Закройте книгу и повторите попытку."
        Else
            'помещаем файл в архив
            lZIPCnt = lZIPCnt + 1
            objShell.Namespace((sZIPFileName)).CopyHere CStr(avFiles(lf))
            'дожидаемся окончания архивации(особенно актуально для больших файлов)
            Do Until objShell.Namespace((sZIPFileName)).Items.Count = lZIPCnt
                DoEvents
            Loop
        End If
    Next lf
    If lZIPCnt Then
        MsgBox "Архив создан по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"
    End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : IsBookOpen
' Purpose   : функция проверяет, отрыта ли книга в данный момент.
'             Если открыта - её невозможно поместить в архив
'             http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/
'---------------------------------------------------------------------------------------
Function IsBookOpen(wbName As String) As Boolean
    Dim wbBook As Workbook: On Error Resume Next
    Set wbBook = Workbooks(wbName)
    IsBookOpen = Not wbBook Is Nothing
End Function

'---------------------------------------------------------------------------------------
' Procedure : Zip_All_Files_in_Folder
' DateTime  : 03.08.2014 21:53
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Создание архива из всех файлов в указанной папке
'---------------------------------------------------------------------------------------
Sub Zip_All_Files_in_Folder()
    Dim sFolderName As String, oFolder As Object
    Dim sDate As String, sZIPPath As String, sZIPFileName As String
    Dim objShell As Object
 
    sZIPPath = Application.DefaultFilePath
    If Right(sZIPPath, 1) <> "\" Then
        sZIPPath = sZIPPath & "\"
    End If
 
    sDate = Format(Now, " dd-mm-yy h-mm-ss")
    sZIPFileName = sZIPPath & "VBAZip " & sDate & ".zip"
 
    Set objShell = CreateObject("Shell.Application")
    'Выбираем папку
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolderName = .SelectedItems(1)
    End With
    'создаем пустой ZIP-архив
    CreateNewZip (sZIPFileName)
    If Right(sFolderName, 1) <> "\" Then
        sFolderName = sFolderName & "\"
    End If
    'помещаем файлы из папки в архив
    objShell.Namespace((sZIPFileName)).CopyHere objShell.Namespace((sFolderName)).Items
    'дожидаемся окончания архивации
    Do Until objShell.Namespace((sZIPFileName)).Items.Count = objShell.Namespace((sFolderName)).Items.Count
        DoEvents
    Loop
    MsgBox "Архив создан по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Zip_ActiveWorkbook
' DateTime  : 03.08.2014 21:54
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Создание архива с резервной копией активной книги
'---------------------------------------------------------------------------------------
Sub Zip_ActiveWorkbook()
    Dim sDate As String, sZIPPath As String
    Dim sZIPFileName, sBackupFileName
    Dim objShell As Object
    Dim sEx As String, lp As Long
 
    sZIPPath = Environ("TEMP")    'путь по умолчанию к папке временных файлов
    'можно указать любой, например
    'sZIPPath = "C:\temp" 'путь должен существовать
    If Right(sZIPPath, 1) <> "\" Then
        sZIPPath = sZIPPath & "\"
    End If
    'получаем расширение активной книги
    lp = InStrRev(ActiveWorkbook.Name, ".")
    If lp > 0 Then
        sEx = Mid(ActiveWorkbook.Name, lp)
    End If
 
    If Not sEx Like ".xl*" Then
        MsgBox "Неизвестный формат активной книги", vbInformation, "www.excel-vba.ru"
        Exit Sub
    End If
 
    sDate = Format(Now, " yyyy-mm-dd h-mm-ss")
    'имя архива
    sZIPFileName = sZIPPath & Left(ActiveWorkbook.Name, _
                                   Len(ActiveWorkbook.Name) - Len(sEx)) & sDate & ".zip"
    'имя временного файла
    sBackupFileName = sZIPPath & Left(ActiveWorkbook.Name, _
                                      Len(ActiveWorkbook.Name) - Len(sEx)) & sDate & sEx
    'если файла архива и такой же книги еще нет в папке
    If Dir(sZIPFileName) = "" And Dir(sBackupFileName) = "" Then
        'создаем копию активной книги
        'т.к. открытую книгу нельзя поместить в архив
        ActiveWorkbook.SaveCopyAs sBackupFileName
        'создаем пустой ZIP-архив
        CreateNewZip (sZIPFileName)
        'помещаем файл в архив
        Set objShell = CreateObject("Shell.Application")
        objShell.Namespace((sZIPFileName)).CopyHere sBackupFileName
        'дожидаемся окончания архивации
        Do Until objShell.Namespace((sZIPFileName)).Items.Count = 1
            DoEvents
        Loop
        'удаляем временный файл
        Kill sBackupFileName
        MsgBox "Резервная копия книги создана по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"
    Else
        MsgBox "Невозможно создать архив, т.к. такая книга или архив уже присутствуют в папке", vbInformation, "www.excel-vba.ru"
    End If
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ExtractFileFromZip
' DateTime  : 03.08.2014 22:02
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Извлечение из архива конкретного файла
'---------------------------------------------------------------------------------------
Sub ExtractFileFromZip()
'C:\Documents            - папка для извлечения файла из архива
'C:\Documents\VBAZip.zip - имя ZIP-архива, из которого необходимо извлечь файл
'Книга1.xls              - имя файла в ZIP-архиве, который необходимо извлечь
    With CreateObject("Shell.Application").Namespace(("C:\Documents"))
        .CopyHere "C:\Documents\VBAZip.zip" & "\" & "Книга1.xls"
    End With
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ExtractFromZipToFolder
' DateTime  : 03.08.2014 21:55
' Author    : The_Prist(Щербаков Дмитрий)
'             http://www.excel-vba.ru
' Purpose   : Извлечение всех файлов из архива
'---------------------------------------------------------------------------------------
Sub ExtractAllFilesFromZip()
'"C:\Documents"            - папка для извлечения файлов из архива
'"C:\Documents\VBAZip.zip" - имя ZIP-архива, из которого необходимо извлечь файлы
    With CreateObject("Shell.Application")
        .Namespace(("C:\Documents")).CopyHere .Namespace(("C:\Documents\VBAZip.zip")).Items
    End With
End Sub