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

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

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

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

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