Функция предназначена для получения файлов, извлечённых из архива 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

• 15060 просмотров