Как программно узнать закончил ли ZIP свою работу?

Option Explicit
'
'    © FelixMacintosh 2014
'
Private Shell As Object '
Private Fso As Object '
Private mArchive As Object
'
Public Event CopyWait(Cancel As Boolean, Parent As Object)
'Значение отмены // папка // объект
Private Type THREADENTRY32
    dwSize As Long
    cntUsage As Long
    th32ThreadID As Long
    th32OwnerProcessID As Long
    tpBasePri As Long
    tpDeltaPri As Long
    dwFlags As Long
End Type
 
Private Declare Function Thread32First Lib "kernel32" (ByVal hSnapshot As Long, ByRef lpte As THREADENTRY32) As Long
Private Declare Function Thread32Next Lib "kernel32" (ByVal hSnapshot As Long, ByRef lpte As THREADENTRY32) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenThread Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
Private Const INFINITE = -1&
Private Const SYNCHRONIZE = &H100000
Private Const TH32CS_SNAPTHREAD = &H4
 
 
Private Sub GetThreadsList(List As Collection)
    '
    '   Возвращает List с коллекцией потоков
    '
    Dim hSnap As Long, TE As THREADENTRY32, PID As Long
    Set List = New Collection
    hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0)
    If hSnap = -1 Then Exit Sub
    TE.dwSize = Len(TE)
    PID = GetCurrentProcessId()
    If Thread32First(hSnap, TE) Then
        Do
            If TE.th32OwnerProcessID = PID Then List.Add TE.th32ThreadID, "C" & CStr(TE.th32ThreadID)
        Loop While Thread32Next(hSnap, TE)
    End If
    CloseHandle hSnap
End Sub
Private Function GetParentDate(Parent) As Date
    '
    '   Возврат даты папки назначения
    '
    On Error Resume Next
    If IsObject(Parent) Then
        GetParentDate = Parent.self.ModifyDate
    Else
        GetParentDate = Shell.NameSpace((Parent.self.Path)).ModifyDate
    End If
End Function
 
Private Function GetItemDate(Parent, vItem) As Date
    '
    '   Возврат даты объекта, в папке назначения
    '
    Dim ParentName$, ItemName$
    On Error Resume Next
    If IsObject(Parent) Then
        ParentName = Parent.self.Path
    Else
        ParentName = Fso.GetAbsolutePathName(Parent)
    End If
    '-------------------
    If IsObject(vItem) Then
        If TypeName(vItem) = "FolderItems3" Then
            ItemName = NameArchiveFiles(0)
        Else
            ItemName = vItem.Name
        End If
    Else
        ItemName = Right$(CStr(vItem), Len(vItem) - InStrRev(vItem, "\"))
    End If
    GetItemDate = Shell.NameSpace((ParentName)).ParseName((ItemName)).ModifyDate
 
End Function
Private Function ParentCount(Parent) As Long
    '
    '   Возврат количества объектов в корневой папке
    '
'    On Error Resume Next
   If IsObject(Parent) Then
        ParentCount = Shell.NameSpace((Parent.self.Path)).items().Count
    Else
        ParentCount = Shell.NameSpace((Parent)).items().Count
    End If
End Function
 
Private Function CopyHere(Parent, vItem) As Boolean
    '
    'Функция копирования
    'Аргументы: Папка (Zip-папка) // Копируемый объект
 
    Dim f&, Key$, hnd&, ParD As Date, ItemD As Date, PCount&
    Dim aTrd As Collection, bTrd As Collection, cTrd As Collection, tid As Long, hTrd As Long
    On Error Resume Next
 
    ParD = GetParentDate(Parent)
    ItemD = GetItemDate(Parent, vItem)
    PCount = ParentCount(Parent)
    'Получаем список потоков !
    GetThreadsList aTrd 'Запомнить старые потоки
    Call Parent.CopyHere((vItem)) 'Копирование >>>>>>>>>>>>
    
    GetThreadsList bTrd 'Запомнить новые потоки
    If vItem.Count > 0 Then If Err.Number = 0 Then GoTo 1 'В этом случае ждать не нужно
    Err.Clear 'Сброс всех ошибок
 
    Set cTrd = New Collection
    For f = bTrd.Count To 1 Step -1
        Key = "C" & bTrd.Item(f)
        hnd = aTrd(Key)
        If hnd = 0 Then cTrd.Add CLng(Mid$(Key, 2))
    Next
 
    For f = 1 To cTrd.Count 'Ожидание открытых потоков
        tid = cTrd.Item(f)
        hTrd = OpenThread(SYNCHRONIZE, False, tid)
        WaitForSingleObject hTrd, INFINITE
        CloseHandle hTrd
    Next
1
    CopyHere = (ItemD <> GetItemDate(Parent, vItem))
    CopyHere = CopyHere Or (ParD <> GetParentDate(Parent))
    CopyHere = CopyHere Or (PCount <> ParentCount(Parent))
End Function
 
 
Public Function UnZipFile(ByVal DestPath$, ParamArray Files()) As Boolean
    '
    'Извлечение из архива
    'Аргументы:
    'DestPath - полный путь к папке для распаковки архива
    'Files - Без параметра все файлы, либо по индексу либо имени в архиве
    'Примечание: Имена файлов в архиве, должны быть полными !
    '
    Dim DestDir As Object, f&, v As Variant, ind&
    If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    ReDim Obj(mArchive.items.Count - 1) As Object
 
    If Not Fso.FolderExists(DestPath) Then 'Проверяем есть ли папка
        Fso.CreateFolder (DestPath) 'Создаём папку для перемещаемых туда объектов
    End If
    Set DestDir = Shell.NameSpace((DestPath))
 
    If IsMissing(Files) Then
        'DestDir.CopyHere mArchive.Items
        UnZipFile = CopyHere(DestDir, mArchive.items)
    Else
 
        For Each v In Files 'Подготавливаем список для перемещения
 
            If IsNumeric(v) Then
                'Если это индексы
                Set Obj(ind) = mArchive.items().Item(CLng(v))
                If Not (Obj(ind) Is Nothing) Then ind = ind + 1
            Else
                'Если это имена
                Set Obj(ind) = mArchive.ParseName(CStr(v))
                If Not (Obj(ind) Is Nothing) Then ind = ind + 1
            End If
        Next
 
        For f = 0 To ind - 1 'Перемещаем выбранные объекты
            'DestDir.CopyHere Obj(f)
            UnZipFile = CopyHere(DestDir, Obj(f))
        Next
    End If
End Function
 
Public Function NameArchiveFiles$(Optional ByVal ind&, Optional ByVal NameOnly As Boolean)
    '
    'Возврат имени файла в архиве
    'Аргументы:
    'ZipName - имя архива
    'Ind - номер файла в архиве (начало с 0), по умолчанию - 0
    'NameOnly - Только имя, без расширения
    '
    If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    On Error Resume Next
    If NameOnly Then
        NameArchiveFiles = mArchive.items().Item((ind)).Рath
    Else
        NameArchiveFiles = mArchive.items().Item((ind)).Name
    End If
End Function
 
Public Function CopyFileToArchive(ByVal FilePath$) As Boolean
    '
    'Копирует файл / папку в архив
    '
    If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
 
    If Len(Dir(FilePath, vbDirectory)) > 0 And Len(Dir(FilePath)) = 0 Then
 
        If Shell.NameSpace((FilePath)).items.Count = 0 Then
            MsgBox ("Нельзя добавить пустую папку")
            Exit Function
        End If
    End If
    'mArchive.CopyHere (FilePath)
    CopyFileToArchive = CopyHere(mArchive, FilePath) 'Копируем в архив
End Function
 
Public Function CreateArchive(ByVal Рath$) As Boolean
    '
    'Создаёт новый архив
    'Возврат утверждения о создании
    '
    If LCase(Fso.GetExtensionName(Рath)) <> "zip" Then Exit Function
    If Fso.FileExists(Рath) Then Kill Рath
    Fso.CreateTextFile(Рath, True).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
    Set mArchive = Shell.NameSpace((Рath))
    CreateArchive = Not (mArchive Is Nothing) 'Возврат утверждения о создании
End Function
 
Private Sub Class_Initialize()
    Set Shell = CreateObject("Shell.Application")
    Set Fso = CreateObject("Scripting.FileSystemObject")
End Sub
 
Private Sub Class_Terminate()
    Set Shell = Nothing
    Set Fso = Nothing
End Sub
 
Public Property Get Archive() As Variant
    '
    'Возвращает объект архива
    '
    Set Archive = mArchive
End Property
 
Public Property Let Archive(ByVal vNewValue As Variant)
    '
    'Свойство: Archive = Файловый путь
    '
    If Fso.FileExists(vNewValue) Then
        Set mArchive = Shell.NameSpace((vNewValue))
    End If
End Property
 
Public Property Set Archive(ByVal vNewValue As Variant)
    '
    'Свойство: Archive = Cсылка на файловый объект архива
    '
    On Error Resume Next
    Set Archive = vNewValue
End Property
 
Public Property Get Count() As Long
    If (mArchive Is Nothing) Then Exit Property
    Count = mArchive.items().Count
End Property