Получение файлов из архива 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

==================
Более сложный вариант функции извлечения из архива
(макрос пытается применить WinRAR, если тот установлен, ибо с ним заметно быстрее и корректнее работает)

Function ExtractFromArchieve(ByVal SourceFile$, Optional ByVal DestinationFolder$, _
                             Optional ByVal mask$, Optional AllowWinRAR As Boolean = True, Optional ByRef err_msg$) As String
    ' © 2018 ExcelVBA.ru
    ' Извлекает из архива SourceFile$ в папку DestinationFolder$ файлы, соответствующие маске имени файла Mask$
    ' При указании AllowWinRAR = TRUE, макрос для извлечения файлов пытается применить приложение WinRAR.exe
    ' Возвращает путь к папке с извлечёнными файлами
    On Error Resume Next
 
    If SourceFile$ = "" Then err_msg$ = "Ошибка: Не задан путь к файлу архива</b>": Exit Function
 
    If Dir(SourceFile$, vbNormal) = "" Then err_msg$ = "Ошибка: Файл архива на найден: " & SourceFile$: Exit Function
 
    Dim PathArr, FileName$, DestinationFolderName$, WinRAR_Used As Boolean, res, WinRAR_AppPath$, WinRAR_Command$
    If DestinationFolder$ = "" Then
        Const FOLDER_SUFFIX$ = "Extracted.Files"
        PathArr = Split(SourceFile$, "\"): FileName$ = PathArr(UBound(PathArr))
        DestinationFolderName$ = FileName$ & "." & FOLDER_SUFFIX$
        If FileName$ Like "*.*" Then DestinationFolderName$ = Left(FileName$, InStrRev(FileName$, ".")) & FOLDER_SUFFIX$
        PathArr(UBound(PathArr)) = DestinationFolderName$
        DestinationFolder$ = Join(PathArr, "\")
    End If
    If Right(DestinationFolder$, 1) <> "\" Then DestinationFolder$ = DestinationFolder$ & "\"
 
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists(DestinationFolder$) Then
            If InStr(1, DestinationFolder$, FOLDER_SUFFIX$, vbTextCompare) Then
                .DeleteFile DestinationFolder$ & "*.*", True
                .DeleteFolder DestinationFolder$ & "*.*", True
            End If
        End If
        MkDir DestinationFolder$
        DoEvents
        If Not .FolderExists(DestinationFolder$) Then
            err_msg$ = "Ошибка: Не удалось создать папку для извлечения: " & DestinationFolder$
            Exit Function
        End If
    End With
 
    If (mask$ = "") Or (InStr(1, mask$, " ") > 0) Or (InStr(1, mask$, """") > 0) Then mask$ = "*"
 
    If AllowWinRAR Then    ' извлекаем средствами приложения WinRAR
        With CreateObject("Wscript.Shell")
            WinRAR_AppPath$ = .regread("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\WinRAR.exe\")
            If WinRAR_AppPath$ = "" Then WinRAR_AppPath$ = Split(.regread("HKCR\WinRAR\shell\open\command\"), """")(1)
        End With
 
        If Dir(WinRAR_AppPath$) <> "" Then
            WinRAR_Command$ = """" & WinRAR_AppPath$ & """ X -o+ -ac -ibck -inul -n" & mask$ & " """ & SourceFile$ & """ """ & DestinationFolder$ & """"
            res = Shell(WinRAR_Command$, vbHide)
            If Val(res) <> 0 Then WinRAR_Used = True
        End If
    End If
 
    Dim coll As Collection, i&, arr, CurrentFilesCount&, PreviuosFileCount&, oApp As Object, fileNameInZip
    If Not WinRAR_Used Then    ' извлекаем средствами ОС Windows, если не получилось с использование WinRAR
        Set oApp = CreateObject("Shell.Application")
        For Each fileNameInZip In oApp.Namespace(CVar(SourceFile$)).Items
            If fileNameInZip Like mask$ Then
                oApp.Namespace(CVar(DestinationFolder$)).CopyHere oApp.Namespace(CVar(SourceFile$)).Items.Item(CStr(fileNameInZip)), 1024 + 16
            End If
        Next
        Set oApp = Nothing
    End If
 
    DoEvents
    Set coll = FilenamesCollection(DestinationFolder$, "*")
 
    ' проверяем папку с извлеченными файлами с интервалом 0,3 секунды,
    ' и ждём, пока количество файлов не будет меняться
    PreviuosFileCount& = coll.Count
 
    Dim TimeStamp As Double, ProcessTime$, StartTime As Double
    StartTime = Timer
    Do
        If CurrentFilesCount& Then PreviuosFileCount& = CurrentFilesCount&
        TimeStamp = Timer
        While Abs(Timer - TimeStamp) < 0.3: DoEvents: Wend
        Set coll = FilenamesCollection(DestinationFolder$, "*")
        CurrentFilesCount& = coll.Count
    Loop While (CurrentFilesCount& > PreviuosFileCount&) And (Abs(Timer - StartTime) < 10)
 
    If coll.Count = 0 Then Exit Function
    ExtractFromArchieve = DestinationFolder$
End Function
 
Function FilenamesCollection(ByVal FolderPath$, Optional ByVal mask$ = "*", Optional ByVal SearchDeep& = 999) As Collection
    On Error Resume Next: Dim FSO As Object: Set FilenamesCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing
End Function
 
Function GetAllFileNamesUsingFSO(ByVal FolderPath$, ByVal mask$, ByRef FSO, ByRef FileNamesColl As Collection, ByVal SearchDeep&)
    On Error Resume Next: Dim oCurrFolder As Object, oFile As Object, oSubFolder As Object
    Const ExcludeFiles$ = "Thumbs.db, desktop.ini"
 
    Set oCurrFolder = FSO.GetFolder(FolderPath)
    If Not oCurrFolder Is Nothing Then
        For Each oFile In oCurrFolder.Files
            If oFile.Name Like "*" & mask Then
                If InStr(1, ExcludeFiles$, oFile.Name, vbTextCompare) = 0 Then
                    If InStr(1, oFile.Name, "~$", vbTextCompare) <> 1 Then FileNamesColl.Add oFile.Path
                End If
            End If
        Next
        SearchDeep& = SearchDeep& - 1
        If SearchDeep& Then
            For Each oSubFolder In oCurrFolder.SubFolders
                GetAllFileNamesUsingFSO oSubFolder.Path, mask, FSO, FileNamesColl, SearchDeep&
            Next
        End If
        Set oFile = Nothing: Set oSubFolder = Nothing: Set oCurrFolder = Nothing
    End If
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-арт.

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

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