MyTetra Share
Делитесь знаниями!
Получение файлов из архива ZIP на VBA
16.03.2019
23:43
Текстовые метки: k_zip,VBA, ZIP
Раздел: !Закладки - VBA

Получение файлов из архива 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
  • 15060 просмотров
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования