mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Получение файлов из архива ZIP на VBA

Функция предназначена для получения файлов, извлечённых из архива ZIP.

Разархивирование выполняется средствами Windows, файлы извлекаются в специально созданную папку в каталоге для временных файлов (C:\WINDOWS\Temp\)

При запуске макроса папка UNZIPPED FILES сначала удаляется, а потом создаётся заново.
(таким образом, выполняется удаление файлов, которые могли оказаться в папке при предыдущем запуске макроса)

Функция возвращает коллекцию, содержащую полные пути к извлечённым файлам.

См. также функцию UnZip_File, предназначенную для разархивирования файлов
в заданную папку, с возможностью удаления исходного файла-архива.

Пример использования функции FilesFromZip:

Sub ПримерИспользования()
    On Error Resume Next
    file$ = "D:\Проекты\Прайсы\Архив.zip"    ' путь к архиву, из которого будем извлекать файлы
    
    Dim coll As Collection
    Set coll = FilesFromZip(file)
    Debug.Print "Извлечено файлов: " & coll.Count ' выводи количество файлов
    
    For Each filename In coll ' выводим пути к извлечённым из архива ZIP файлам
        Debug.Print filename
    Next
End Sub

 

Результат:

Извлечено файлов: 7
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист BMW.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист LAMBO.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист Porche.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист ROVER.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс лист VAG.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс-лист Ford.xls
C:\WINDOWS\Temp\UNZIPPED FILES\Прайс-лист Мерседес.xls

 

Код функции FilesFromZip:

Для работы функции, необходимо дополнительно скопировать
в стандартный модуль код функции FilenamesCollection

Function FilesFromZip(ByVal FileNameZip) As Collection
    ' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
    ' (предварительно удаляя папку с таким именем, если она существует)
    ' Возвращает коллекцию, содержащую пути ко всем извлечённым из архива файлам)
    On Error Resume Next: Err.Clear: Set FilesFromZip = New Collection
 
    folder = Environ("tmp") & "\UNZIPPED FILES\"
    Shell "cmd /c rd /S/Q """ & folder & """"    ' удаляем папку
    DoEvents: DoEvents: DoEvents: DoEvents:
    MkDir folder    ' и создаём эту папку заново
    DoEvents: DoEvents: DoEvents: DoEvents: Err.Clear
 
    If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function    ' не удалось создать папку
    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
       vbCritical, "Ошибка в функции FilesFromZip": Exit Function
 
    Set oApp = CreateObject("Shell.Application")
    For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents:  Next
 
    oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items    'распаковываем файлы
    Set FilesFromZip = FilenamesCollection(folder, "*")
End Function


Другая версия функции, - работает более стабильно,
возвращает путь к файлу XLS из архива:
Function FileFromZip(ByVal FileNameZip) As String
    ' Функция осуществляет распаковку архива с именем FileNameZip во временную папку
    ' возвращает путь к разархивированному файлу Excel
     On Error Resume Next: Err.Clear
 
    folder = Environ("tmp") & "\UNZIP_" & Timer & "\"
    MkDir folder        ' и создаём эту папку заново

    If Len(Dir(folder, vbDirectory)) = 0 Then Exit Function        ' не удалось создать папку
    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
       vbCritical, "Ошибка в функции FilesFromZip": Exit Function
 
    Set oApp = CreateObject("Shell.Application")
    For Each it In oApp.Namespace(FileNameZip).Items: DoEvents: DoEvents: Next
 
    oApp.Namespace(folder).CopyHere oApp.Namespace(FileNameZip).Items        'распаковываем файлы
    filename$ = folder & Dir(folder & "*.xls*", vbNormal)
    If Dir(filename$, vbNormal) Then FileFromZip = filename$
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

по поводу "Win8.1 - строчка "oApp.Namespace(Folder ).CopyHere oApp.Namespace(FileNameZip ).Items" почему-то не работает, файлы не распаковываются."
по видимому речь про функцию "Function FilesFromZip(ByVal FileNameZip) As Collection"
полагаю в ней ошибка аналогичная той, что не даёт работать "Function UnZip_File(ByVal FileNameZip, ByVal DestinationFolder, Optional ByVal DeleteSourceFile As Boolean = False) As Boolean"
достаточно указать в команде
oApp.Namespace(DestinationFolder).CopyHere oApp.Namespace(FullFileNameZip).Items 'распаковываем файлы
полный путь к распаковываемому файлу (FullFileNameZip = DestinationFolder + FileNameZip)
чтобы файлы начали успешно распаковываться
p.s. адиминистратору сайта - проверьте пожалуйста моё предположение, и если оно верно, внесите корректировки в код опубликованных на сайте макросов

Win8.1 - строчка "oApp.Namespace(Folder).CopyHere oApp.Namespace(FileNameZip).Items" почему-то не работает, файлы не распаковываются.

И по поводу самой концепции функции - обидно, что нельзя считывать структуру архива без дурацкой распаковыки всего и вся на диск

Здравствуйте, Сергей.
Этот макрос использует встроенные средства Windows для извлечения файлов из архива,
потому там нет возможностей программы WinRAR

Поэтому, надо использовать совсем другой макрос.

у рара есть опция распакавать только файлы удовлетворяющие определённой маске, пытаюсь воспользоваться этой опцией... не получается.. помогите плис

УРА!!!!!
Огромное ВАМ спасибо. Все заработало, дело действительно было в кавычках.

Можно указывать любые пути

PS: Код этот я не проверял, и, возможно, он заработает, только если добавить кавычки в путь к приложению (ибо он содержит пробел)

Вот так точно всё будет работать корректно:
(обратите внимание на двойные и тройные кавычки)

Sub UnRar()
    ' задаем пути к приложению, к папке для извлеченных файлов, и к файлу архива RAR
    WinRarApp$ = """C:\Program Files\WinRAR\WinRAR.exe"" e -o+"
    FolderForFiles$ = """C:\Temp\АРХИВ RAR\"""
    ArchievePath$ = """C:\Documents and Settings\Admin\Рабочий стол\AOPR v3.13.rar"""
 
    ' формируем команду
    adr$ = WinRarApp$ & " " & ArchievePath$ & " " & FolderForFiles$
 
    Shell adr$, vbHide    ' выполняем команду
End Sub

Доброго времени суток!
Спасибо за подробные разъяснения, но у меня сама программа отрабатывает но выскакивает сообщение: Архивы не найдены!
А можно ли путь к разархивированию указывать произвольный или обязательно через "C:\Temp\"

Sub UnRar()
WinRarApp$ = "C:\Program Files\WinRAR\WinRAR.exe e -o+"
iPath = "C:\Temp\АРХИВ RAR\"
iArhivName$ = "C:\Documents and Settings\Рабочий стол\Тest\346.rar"
adr$ = WinRarApp$ & " """ & iPath & iArhivName$ & """ """ & iPath & """ "
RetVal = Shell(adr$, vbHide) 'vbNormalFocus)
End Sub

Здравствуйте, Андрей.

Макрос предназначен только для архивов ZIP (c которыми Windows может работать сама, без привлечения сторонних программ)
С форматом архива RAR, увы, Windows не знакома, - поэтому тут надо привлекать сторонний софт (например, программу WinRAR)

Делается это примерно так: (и работает, кстати, быстрее и стабильнее, чем работа с ZIP папками средствами Windows)

Sub UnRar()
   'Разархивируем архив C:\Temp\Test 5.rar
    WinRarApp$ = "C:\Program Files\WinRAR\WinRAR.exe e -o+"
    ' e  - разархивировать
    ' -o+  - перезаписывать существующие файлы
    iPath = "C:\Temp\"
    iArhivName$ = "Test 5.rar"
    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.
    'без кавычек пробелы недопустимы
    adr$ = WinRarApp$ & " """ & iPath & iArhivName$ & """ """ & iPath & """ "
    RetVal = Shell(adr$, vbHide)  'vbNormalFocus)
End Sub

PS: Правильнее было бы брать путь к программе WinRAR из реестра (ведь она может быть установлена в любую папку)
Но и в таком варианте код работает.

PS: У WinRAR есть множество ключей, с которыми можно его запускать (в примере макроса используются только 2 ключа),
так что можно очень гибко работать с архивами из макроса Excel
И, разумеется, таким образом (через WinRAR) можно работать с любыми типами архивов - не только RAR, но и ZIP, и т.д. и т.п.

Доброго времени суток!

У меня почему то временная папка создается а вот файл Архив.rar не распаковывается во временную папку "\UNZIPPED FILES\"?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ____   _   _                 ____   ____  
/ ___| | | | | ___ ___ / ___| | ___|
| | | |_| | / __| / __| | | |___ \
| |___ | _ | \__ \ | (__ | |___ ___) |
\____| |_| |_| |___/ \___| \____| |____/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.