Хитрости »
Основные понятия (23)
Сводные таблицы и анализ данных (9)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (14)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (63)
Разное (38)
Баги и глюки Excel (2)

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

В данной статье я постараюсь описать и показать, как можно средствами Visual Basic for Applications создать архив и извлечь данные из архива(иными словами архивировать и разархивировать файлы).


АРХИВАЦИЯ ЧЕРЕЗ WinRAR
В принципе, все очень даже просто. В функция для архивации и извлечения используется архиватор WinRAR, т.к. он является самым распространенным и есть почти на каждом ПК. Процедура CallRARFunction показывает как можно вызвать функции работы с WinRAR-ом. Остальные функции выполняют непосредственно всю "грязную" работу. Я специально решил привести пример с процедурой вызова и отдельными функциями. Чтобы при необходимости можно было функции записать, а вызов выполнять уже где угодно.

Первое обязательное условие для вызова всех функций - необходимо объявить константу с путем к исполняемому файлу архиватора WinRAR:

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

Данные две строки помещаются в самый верх модуля, в котором будут описаны функции работы с архивами. Указывается полный путь к файлу WinRAR.exe. В строке выше указан путь, по которому WinRAR устанавливается по умолчанию. Однако если WinRAR установлен в другую папку - необходимо указать её. Например: "C:\Обязательные программы\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


 
АРХИВАЦИЯ ПАПКИ - WinRAR

'---------------------------------------------------------------------------------------
' 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


 
АРХИВАЦИЯ ФАЙЛА - WinRAR

'---------------------------------------------------------------------------------------
' 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


 
ИЗВЛЕЧЕНИЕ ИЗ АРХИВА ПАПКИ/ФАЙЛА - WinRAR

'---------------------------------------------------------------------------------------
' 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

Ничего сложного - функции делают одно - вызывают посредством объекта Shell архиватор WinRAR, передавая ему указанные параметры. Для большинства задач функции вполне подойдут без каких-либо изменений. Если лень разбираться - можно просто последовательно скопировать ВСЕ коды данной статьи и вставить их в стандартный модуль.
А для тех, кто хочет углубиться и поэкспериментировать - можно почитать дальше и узнать какие можно применить команды и ключи для более гибкого использования WinRAR вместе с VBA.
Синтаксис передачи параметров WinRAR:
WinRAR [команда] -[ключ1] -[ключN] [архив] [файлы…] [@файл-список…] [путь для извлечения\]

 
ОПИСАНИЕ ПАРАМЕТРОВ WinRAR

Параметр Описание
команда Комбинация символов, определяющая действие, которое будет выполнять WinRAR.
ключ Ключи используются для определения специфических действий, степени сжатия, типа архива и пр.
архив Имя обрабатываемого архива.
файлы Имена обрабатываемых файлов.
файл-список Файлы-списки - это обычные текстовые файлы, содержащие имена файлов для обработки. Каждое имя файла должно быть указано на отдельной строке и начинаться с первой позиции строки. В файл-список допускается помещать комментарии, признак начала комментария - символы //. Например, для архивирования файлов *.txt из папки c:\work\doc, файлов *.bmp из папки c:\work\image и всех файлов из папки c:\work\misc можно создать backup.lst, содержащий следующие строки:
c:\work\doc\*.txt//резервная копия текстов
c:\work\image\*.bmp//резервная копия рисунков
c:\work\misc

После этого для архивирования достаточно будет выполнить команду:
winrar a backup @backup.lst

В одной командной строке разрешается указывать как обычные имена или группы файлов для обработки, так и файлы-списки. Если не указаны ни файлы, ни файлы-списки, то подразумевается шаблон *.* (т.е. WinRAR обработает все файлы).

путь для извлечения Используется только с командами e и x и указывает папку, в которую нужно извлекать файлы. Если эта папка не существует, то она будет создана.

В одну строку можно передать сразу несколько команд и ключей. Главное, чтобы порядок их не противоречил синтаксису передачи параметров. Сначала необходимые команды, далее ключи и т.д. Например, в функции FileToRAR я использую команду и два параметра - " A -ep -df ". Если все перевести в одну строку, заменив все переменные значениями, то получится такая строка:
Shell("C:\Program Files\WinRAR\WinRAR.exe A -ep -df ""C:\Temp\Test.rar "" ""C:\Temp\Test.xls"" ", vbHide)
Попробуем прочитать строку:
WinRAR должен поместить в архив файл C:\Temp\Test.xls, имя создаваемого архива - C:\Temp\Test.rar. После успешной архивации исходный файл C:\Temp\Test.xls будет удален(ключ -df). Пути в именах не отображаются(ключ -ep).
Команду я записал с большой буквы для визуального разделения, но этого не требуется, ключи и команды не чувствительны к регистру. Ниже я привожу таблицы с перечислением и расшифровкой всех команд и функций, доступных в WinRAR. Так же их всегда можно посмотреть в справке самого WinRAR.


 
ТАБЛИЦА КОМАНД WinRAR
[spoiler effect="blind" show="Раскрыть таблицу"]

Команда Описание
A Добавить файлы в архив
C Добавить архивный комментарий
CH Изменить параметры архива
CV Преобразовать архивы
CW Записать в файл комментарий архива
D Удалить файлы из архива
E Извлечь файлы из архива, игнорируя пути
F Освежить имеющиеся файлы в архиве
I Найти строку в архивах
K Заблокировать архив
M Переместить файлы и папки в архив
R Восстановить повреждённый архив
RC Воссоздать недостающие тома
RN Переименовать файлы в архиве
RR[N] Добавить информацию для восстановления
RV[N] Создать тома для восстановления
S[имя] Преобразовать архив в самораспаковывающийся
S- Удалить SFX-модуль
T Протестировать файлы в архиве
U Обновить файлы в архиве
X Извлечь файлы из архива с полными путями

[/spoiler]


 
ТАБЛИЦА КЛЮЧЕЙ WinRAR
Чуть подробнее стоит остановиться на ключах к WinRAR. Их использование значительно расширяет возможности архивирования и дальнейшей обработки файлов. Для чего они нужны и как применить? Очень просто. Если взглянуть на функции, приведенные выше, то можно увидеть пару примеров использования ключей и команд.
Ниже приведена полная таблица ключей и их описание:
[spoiler effect="blind" show="Раскрыть таблицу"]

Ключ Описание ключа
-ac Снять атрибут "архивный" после архивации или извлечения
-ad Добавить к пути назначения имя архива
-af<тип> Указать формат архива
-ag[формат] Добавить к имени архива текущую дату и время
-ao Добавить файлы с установленным атрибутом "архивный"
-ap<путь> Установить путь внутри архива
-as Синхронизировать содержимое архива
-av Добавить электронную подпись
-av- Запретить добавление/проверку электронной подписи
-cfg- Игнорировать профиль по умолчанию и переменную окружения
-cl Преобразовать имена файлов в нижний регистр
-cu Преобразовать имена файлов в верхний регистр
-df Удалить файлы после архивации
-dh Открывать совместно используемые файлы
-ds Не сортировать файлы при архивации
-ed Не добавлять пустые папки
-en Не добавлять блок "конец архива"
-ep Исключить пути из имён
-ep1 Исключить из пути базовую папку
-ep2 Сохранять полные пути файлов
-ep3 Сохранять полные пути, включая букву диска
-e[+]<атр> Задать исключение или включение файлов из/в обработку по маске атрибутов
-f Освежить имеющиеся файлы
-hp[пароль] Шифровать и данные, и заголовки файлов
-iadm Запрашивать административный доступ для SFX-архива
-ibck Запустить WinRAR как фоновый процесс в системном лотке
-ieml[.][адрес] Отправить архив по электронной почте
-iicon<имя > Указать значок для SFX-модуля
-iimg<имя> Указать логотип для SFX-модуля
-ilog[имя] Записывать протокол ошибок в файл
-inul Не выводить сообщения об ошибках
-ioff Выключить компьютер
-k Заблокировать архив
-kb Сохранять на диске файлы, извлечённые с ошибками
-m<n> Установить метод сжатия
-mc<параметры> Указать дополнительные параметры сжатия
-md<n> Установить размер словаря
-ms[список] Указать типы файлов для архивирования без сжатия
-mt<потоки> Установить число потоков
-n<файл> Включить в обработку только указанный файл
-n@<файл-список> Включить в обработку только файлы, указанные в файле-списке
-oc Установить NTFS-атрибут "сжатый"
-or Переименовывать файлы автоматически
-os Сохранить потоки NTFS
-ow Обработать информацию о правах доступа к файлам
-o+ Перезаписывать существующие файлы
-o- Не перезаписывать существующие файлы
-p[пароль] Установить пароль
-r Обрабатывать вложенные папки
-r0 Обрабатывать вложенные папки по шаблону
-ri Установить приоритет и время простоя
-rr[N] Добавить информацию для восстановления
-rv[N] Создать тома для восстановления
-s Создать непрерывный архив
-s<N> Создать непрерывные группы, используя счётчик файлов
-sc<набор символов>[объекты] Указать набор символов (и объекты)
-se Создать непрерывные группы, используя расширения файлов
-sfx[имя] Создать самораспаковывающийся архив
-sl<размер> Обрабатывать файлы размером меньше указанного
-sm<размер> Обрабатывать файлы размером больше указанного
-sv Создать независимые непрерывные тома
-sv- Создать зависимые непрерывные тома
-s- Запретить создание непрерывных архивов
-t Протестировать файлы после архивирования
-ta<дата> Обрабатывать файлы, изменённые после указанной даты
-tb<дата> Обрабатывать файлы, изменённые до указанной даты
-tk Сохранять исходное время архива
-tl Установить время архива по самому новому файлу
-tn<время> Обрабатывать файлы не старее, чем указанный период времени
-to<время> Обрабатывать файлы более старые, чем указанный период времени
-ts<m,c,a> Сохранить/восстановить время файлов (модификации, создания, последнего доступа)
-u Обновить файлы
-v<n>[k |b|f|m|M|g|G] Создать многотомный архив
-vd Очищать сменный диск перед архивацией на него
-ver[n] Управление версиями файлов
-vn Использовать старую схему именования томов
-vp Делать паузу перед каждым томом
-x<файл > Не обрабатывать указанный файл
-x@<файл-список > Не обрабатывать файлы, указанные в файле-списке
-y Подразумевать ответ "Да" на все запросы
-z<файл> Прочитать комментарий архива из файла
-- Прервать дальнейший поиск ключей в командной строке

[/spoiler]



 
ТАБЛИЦА ПАРАМЕТРОВ ОКНА ДЛЯ Shell
И таблица параметров и их значений для команды Shell, через которую осуществляется вызов архиватора:
[spoiler effect="blind" show="Раскрыть таблицу"]

Параметр Значение параметра
vbNormalFocus Будет показан ход выполнения архивации
vbHide Окно архиватора будет скрыто
vbMinimizedFocus Окно архиватора будет свернуто
vbMinimizedNoFocus Окно архиватора будет свернуто, а окно вызвавшей программы активировано
vbMaximizedFocus Окно архиватора будет раскрыто на весь экран и активировано

[/spoiler]


 
 
АРХИВАЦИЯ ВСТРОЕННЫМИ СРЕДСТВАМИ Windows(в ZIP):

ОСНОВНАЯ ПРОЦЕДУРА СОЗДАНИЯ ПУСТОГО ZIP-АРХИВА
 

'---------------------------------------------------------------------------------------
' 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

Данная процедура создает пустой ZIP-архив, в который далее и помещаются необходимые файлы. Эту процедуру необходимо обязательно копировать вместе с процедурами создания ZIP-архивов, приведенными ниже(Zip_File_Or_Files, Zip_All_Files_in_Folder, Zip_ActiveWorkbook).



АРХИВАЦИЯ ОДНОГО УКАЗАННОГО ФАЙЛА
 

'---------------------------------------------------------------------------------------
' 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


СОЗДАНИЕ ZIP-АРХИВА ИЗ ВСЕХ ФАЙЛОВ В УКАЗАННОЙ ПАПКЕ
 

'---------------------------------------------------------------------------------------
' 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


СОЗДАНИЕ ZIP-АРХИВА С РЕЗЕРВНОЙ КОПИЕЙ АКТИВНОЙ КНИГИ
 

'---------------------------------------------------------------------------------------
' 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


ИЗВЛЕЧЕНИЕ ИЗ ZIP-АРХИВА КОНКРЕТНОГО ФАЙЛА
 

'---------------------------------------------------------------------------------------
' 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


ИЗВЛЕЧЕНИЕ ВСЕХ ФАЙЛОВ ИЗ ZIP-АРХИВА
 

'---------------------------------------------------------------------------------------
' 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

Статья помогла? Поделись ссылкой с друзьями!
  Плейлист   Видеоуроки

Поиск по меткам

Access apple watch Multex Outlook Power Query и Power BI VBA работа в редакторе VBA управление кодами Бесплатные надстройки Дата и время Диаграммы и графики Записки Защита данных Интернет Картинки и объекты Листы и книги Макросы и VBA Надстройки Настройка Печать Поиск данных Политика Конфиденциальности Почта Программы Работа с приложениями Работа с файлами Разработка приложений Сводные таблицы Списки Тренинги и вебинары Финансовые Форматирование Формулы и функции Функции Excel Функции VBA Ячейки и диапазоны акции MulTEx анализ данных баги и глюки в Excel ссылки
Обсуждение: 3 комментария
  1. Андрей:

    Добрый день!
    Спасибо за создание такого мануала. Реально все работает.
    Я использую Zip_All_Files_in_Folder. Можно узнать как запаролить созданных архив?

  2. Ольга:

    А если архив необходимо создавать другой программой, например "Atlansys", где можно узнать её ключи?

    • Ольга, попробуйте поискать на сайте программы или в справке. Для каждой программы ключи разные, хоть и могут совпадать. Это все зависит от разработчиков программы.

Поделитесь своим мнением

Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


Для оформления сообщений Вы можете использовать следующие тэги:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

Тренинги

Заказать
Юридическая информация

Использование материалов сайта

Политика Конфиденциальности

ИП Щербаков Дмитрий Валентинович
ОГРНИП: 318502700083307
ИНН: 504013350772

Наши партнеры

Перейти
Перейти

Счетчики

Рейтинг@Mail.ru Яндекс.Метрика
© 2018 Excel для всех   Войти