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

Public Function UnZipFile(ByVal DestPath$, ParamArray Files())
    '
    'Извлечение из архива
    'Аргументы:
    'DestPath - полный путь к папке для распаковки архива
    'Files - Без параметра все файлы, либо по индексу либо имени в архиве
    'Примечание: Имена файлов в архиве, должны быть полными !
    '
    Dim DestDir As Object, s$, f&, j$(), v As Variant
 
    If Not FolderExists(DestPath) Then 'Проверяем есть ли папка
        MkDir (DestPath) 'Создаём папку для перемещаемых туда объектов
    End If
    Set DestDir = Shell.NameSpace((DestPath))
 
    If IsMissing(Files) Then
        DestDir.CopyHere mArchive.Items 'Перемещаем все ...
        '
        '
        '===== Здесь нужен правильный код окончания операции ! ! !
        '
        '
    Else
 
        For Each v In Files 'Подготавливаем список для перемещения
 
            If IsNumeric(v) Then
                s = s & " " & mArchive.Items().Item((v)).Name
            Else
 
                For f = 0 To mArchive.Items.Count - 1
                    If v = mArchive.Items().Item((f)).Name Then s = s & " " & f
                Next
            End If
        Next
        j = Split(Mid$(s, 2)) 'Cписок для перемещения
 
        For f = 0 To mArchive.Items.Count - 1
            s = mArchive.Items().Item(CLng(j(f))).Name
            s = DestPath & "\" & s
            DestDir.CopyHere mArchive.Items.Item(CLng(j(f))) 'Перемещаем указнные инексы
 
            Do 'Ждём пока в папке назначения не появится файл
                Sleep 100 '1/10 доля секунды
            Loop While Len(Dir(s)) = 0
        Next
    End If
End Function

For f = 1 To cTrd.Count 'Ожидание открытых потоков

Option Explicit
 
Private Declare Function SHParseDisplayName Lib "shell32" (ByVal pszName As Long, ByVal IBindCtx As Long, ByRef ppidl As Long, sfgaoIn As Long, sfgaoOut As Long) As Long
Private Declare Function ILFree Lib "shell32" (ByVal pidlFree As Long) As Long
Private Declare Function lstrcpyn Lib "kernel32" Alias "lstrcpynW" (ByVal lpString1 As Long, ByVal lpString2 As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
 
Private Const ZipFldrCLSID = "{E88DCCE0-B7B3-11d1-A9F0-00AA0060FA31}"
Private Const IID_IShellExtInit = "{000214E8-0000-0000-C000-000000000046}"
 
Private Sub Form_Load()
    Dim clsid   As UUID
    Dim iidSh   As UUID
    Dim shExt   As IShellExtInit
    Dim pf      As IPersistFolder2
    Dim pidl    As Long
    Dim file    As String
    Dim cb      As Long
    
    file = "D:\Temp\Temp.zip"
    CLSIDFromString ZipFldrCLSID, clsid
    CLSIDFromString IID_IShellExtInit, iidSh
    
    If CoCreateInstance(clsid, Nothing, CLSCTX_INPROC_SERVER, iidSh, shExt) <> S_OK Then Exit Sub
    Set pf = shExt
    SHParseDisplayName StrPtr(file), 0, pidl, 0, 0
    pf.Initialize pidl
    ILFree pidl
 
    Dim srg     As IStorage
    Dim stm     As IStream
    Dim enm     As IEnumSTATSTG
    Dim itm     As STATSTG
    Dim nam     As String
    Dim buf()   As Byte
    Dim fnum    As Integer
    
    Set srg = pf
    Set enm = srg.EnumElements
    
    ReDim buf(&HFFFF&)
    
    enm.Reset
    Do While enm.Next(1, itm) = S_OK
        cb = lstrlen(itm.pwcsName)
        nam = Space(cb)
        lstrcpyn StrPtr(nam), itm.pwcsName, cb + 1
        CoTaskMemFree itm.pwcsName
        
        If itm.Type <> STGTY_STORAGE Then
            fnum = FreeFile
            Open "D:\temp\Testzip\" & nam For Binary As fnum
            
            Set stm = srg.OpenStream(nam, 0, STGM_READ, 0)
            
            Do
                cb = stm.Read(buf(0), UBound(buf) + 1)
                If cb = 0 Then Exit Do
                If cb <= UBound(buf) Then ReDim Preserve buf(cb - 1)
                Put #fnum, , buf()
            Loop
            Close fnum
        End If
    Loop
End Sub

{BD472F60-27FA-11CF-B8B4-444553540000} Name: Compressed (zipped) Folder Right Drag Handler
{E88DCCE0-B7B3-11D1-A9F0-00AA0060FA31} Name: CompressedFolder
{888DCA60-FC0A-11CF-8F0F-00C04FD7D062} Name: Compressed (zipped) Folder SendTo Target
{11CFFC0A-0F8F-C000-4FD7-D06265CBCDB8} 
{ED9D80B9-D157-457B-9192-0E7280313BF0} Name: Compressed (zipped) Folder DropHandler
{457BD157-9291-720E-8031-3BF09E8BB764}

Option Explicit
 
' ========= Пример архивирования папки ========
Dim Zip, ArcPath, FolderPath
' Где создаем архив
ArcPath      = "h:\_VBS, WSH\Архивация\My_Class\test.zip"
' Какую папку архивируем
FolderPath   = "h:\_VBS, WSH\Архивация\My_Class\ToArc"
 
Set Zip = New ZipClass
if (Zip.CreateArchive (ArcPath)) then ' старый архив затирается
    Zip.CopyFolderToArchive FolderPath
end if
msgbox "Папка " & FolderPath & " заархивирована."
 
 
' ========= Пример добавления файла в уже созданный архив ========
Dim FilePath
' Какой файл архивировать
FilePath     = "h:\_VBS, WSH\Архивация\My_Class\ZipClass.xls"
 
Zip.CopyFileToArchive FilePath
msgbox "Файл " & FilePath & " добавлен к архиву " & ArcPath
 
 
' ================== Распаковка архива ===================
Dim UnpackPath
' Путь, куда распаковуем
UnpackPath   = "h:\_VBS, WSH\Архивация\My_Class\Unpack"
 
Zip.UnpackArchive ArcPath, UnpackPath
msgbox "Архив распакован в папку: " & UnpackPath
 
' --------------------------------------------------------------------------------------
' Класс создания архивов ZIP. Maded by Dragokas
'
' - позволяет обходить ошибку при добавлении пустых папок
' - позволяет добавлять файлы с атрибутом "скрытый"
' - правильно рассчитывает задержку при распаковке в папку, где уже есть другие файлы
' --------------------------------------------------------------------------------------
Class ZipClass
        Private oShApp, oFSO, oArchive, ArcItemsNewCount, oFolderItems, oFolderItem, oArchiveItems, oTarget, oTargetItems, ZipHeader, isEmptyFolder, SHCONTF_FILES_AND_FOLDERS
        Private Sub Class_Initialize() 'Инициализация объектов
            'FolderItems3.Filter method ' [url]http://msdn.microsoft.com/en-us/library/windows/desktop/bb787787(v=vs.85).aspx[/url]
            Const SHCONTF_FOLDERS               = &H20
            Const SHCONTF_NONFOLDERS            = &H40
            Const SHCONTF_INCLUDEHIDDEN         = &H80
            Const SHCONTF_INCLUDESUPERHIDDEN    = &H10000 ' Windows 7 and Later
            SHCONTF_FILES_AND_FOLDERS = SHCONTF_FOLDERS Or SHCONTF_NONFOLDERS Or SHCONTF_INCLUDEHIDDEN Or SHCONTF_INCLUDESUPERHIDDEN
            Set oShApp = CreateObject("Shell.Application")
            set oFSO = CreateObject("Scripting.FileSystemObject")
        End Sub
        Function UnpackArchive(SourceArchive, DestPath) 'Распаковка архива
            Set oArchiveItems = oShApp.NameSpace(SourceArchive).Items
            on error resume next
            if not oFSO.FolderExists(DestPath) then oFSO.CreateFolder(DestPath)
            if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания временной папки распаковки!"): UnpackArchive = false: Exit Function
            on error goto 0
            Set oTarget = oShApp.NameSpace(DestPath)
            set oTargetItems = oTarget.Items
            Dim oSCR: set oSCR = CreateObject("Scripting.Dictionary"): oSCR.CompareMode = 1
            for each oFolderItem in oTargetItems: oSCR.Add oFolderItem.Name, "": Next ' подсчет кол-ва уникальных файлов
            for each oFolderItem in oArchiveItems
                if not oSCR.Exists(oFolderItem.Name) then oSCR.Add oFolderItem.Name, ""
            Next
            'CopyHere option ENUM: [url]http://msdn.microsoft.com/en-us/library/windows/desktop/bb787866(v=vs.85).aspx[/url]
            oTarget.CopyHere oArchiveItems, 4+16 '(4 - no ProgressBar, 16 - Yes to all, 1024 - suppress all errors)
            Do: Wscript.Sleep 200: oTargetItems.Filter SHCONTF_FILES_AND_FOLDERS, "*": Loop Until oTargetItems.Count => oSCR.Count
            UnpackArchive = true: set oArchiveItems = Nothing: set oTarget = Nothing
        End Function
        Function CreateArchive(ZipArchivePath) 'Подготовка ZIP-архива
            If lcase(oFSO.GetExtensionName(ZipArchivePath)) <> "zip" Then WScript.Echo("Указано неверное расширение для архива!"): Exit Function
            ZipHeader = "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
            on error resume next
            with oFSO.OpenTextFile(ZipArchivePath, 2, True)
                if Err.Number <> 0 then WScript.Echo("Не хватает прав для создания архива!"): CreateArchive = False: Exit function
            .Write ZipHeader: .Close: end with
            on error goto 0
            Do: WScript.Sleep(100): Loop until oFSO.FileExists(ZipArchivePath): WScript.Sleep(200) 'выжидаем время, пока ZIP-архив не будет создан
            Set oArchive = oShApp.NameSpace(ZipArchivePath): if Not (oArchive is Nothing) Then CreateArchive = True
        End Function
        Function CopyFileToArchive(srcFilePath) 'Копируем файл в ZIP-архив
            ArcItemsNewCount = oArchive.Items.Count + 1
            Dim srcFileName: srcFileName = oFSO.GetBaseName(srcFilePath)
            for each oFolderItem in oArchive.Items ' Проверяем, существует ли уже такой файл в архиве
                if strcomp(oFolderItem.name, srcFileName) = 0 then ArcItemsNewCount = oArchive.Items.Count - 1: exit for
            next
            oArchive.CopyHere srcFilePath ', 4 + 16 + 1024 'these options works only with unzipped folder
            Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
        End Function
        Function CopyFolderToArchive(srcFolderPath) 'Копируем содержимое папки в ZIP-архив
            Dim sFilter: set oFolderItems = oShApp.NameSpace(srcFolderPath).Items
            oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, "*" 'включаем в архив скрытые файлы
            For each oFolderItem in oFolderItems ' поиск пустых папок
                isEmptyFolder = false
                if oFolderItem.IsFolder then if oFolderItem.GetFolder.Items.Count = 0 then isEmptyFolder = true
                if not isEmptyFolder then sFilter = sFilter & ";" & replace(oFolderItem.Name, ";", "?") ' белый список объектов для фильтра
            Next
            oFolderItems.Filter SHCONTF_FILES_AND_FOLDERS, mid(sFilter, 1)
            ArcItemsNewCount = oArchive.Items.Count + oFolderItems.Count
            oArchive.CopyHere oFolderItems
            Do: Wscript.Sleep 200: Loop Until oArchive.Items.Count => ArcItemsNewCount 'Выжидаем пока кол-во объектов в ZIP-архиве станет >= копируемым в него
        End Function
End Class

Const TH32CS_SNAPTHREAD = &H4
Const SYNCHRONIZE = &H100000
Const lenNow = 21
Const WM_KEYDOWN = &H100
Const GW_CHILD = 5, GW_HWNDNEXT = 2, cc = 100
'
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 Type tActCTL
    ForegroundWindow As Long
    ClassName As String
    Child As Long
    ChildClassName As String
    ChildText As String
End Type
'
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) 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 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 GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
'
Dim FSO As FileSystemObject ' Object
Dim ShellApp As Shell, LogStream As TextStream, dicParsers As Dictionary
'
Dim FileVB6_EXE$, m_OutDir$, m_ZipName$, m_InitDir$, m_OldDir$, m_DelImport As Boolean
Dim LogPath As String, mParsers()
 
 
Property Let DelImport(ByVal vNewValue As Boolean)
    m_DelImport = vNewValue
    LogWriteLine "DelImport", m_DelImport
End Property
 
Private Sub LogWriteLine(ByVal ProcName$, Optional ByVal Text$)
    Dim s As String * lenNow
    LSet s = Now: LogStream.WriteLine s & "[" & ProcName & "]" & Text$
End Sub
 
Private Function ErrorFO(ByVal ProcName$)
    'Откат созданных файлов и папок
    '
    Dim s$, j$(), f&, vEach
    j = Split(FSO.OpenTextFile(LogPath).ReadAll, vbCrLf)
    LogWriteLine "ErrorFO", ProcName
    On Error Resume Next
    For f = UBound(j) To 0 Step -1
        For Each vEach In Array("CreateFolder", "CreateFile", ProcName)
            If InStr(1, j(f), "[" & vEach & "]") = lenNow + 1 Then
                s = Trim(Mid$(j(f), Len(vEach) + lenNow + 3))
                Select Case vEach
                Case "CreateFolder": FSO.DeleteFolder s: LogWriteLine "DeleteFolder", s
                Case "CreateFile": FSO.DeleteFile s: LogWriteLine "DeleteFile", s
                Case ProcName: Exit Function
                End Select
            End If
    Next: Next
End Function
 
Private Function CreateFile(ByVal AbsPath$, Optional Text) As Boolean
    'Проверяет путь и при не обходимости создаёт недостающие папки и файл
    '
    CreateFile = FSO.FileExists(AbsPath)
    If CreateFile Then Exit Function
    '---------------
    If CreateFolder(FSO.GetParentFolderName(AbsPath)) Then
        On Error Resume Next
        FSO.CreateTextFile(AbsPath).Write Text
        If Err = 0 Then LogWriteLine "CreateFile", AbsPath
    End If
    CreateFile = FSO.FileExists(AbsPath)
End Function
 
Private Function apn$(Path$)
    apn = FSO.GetAbsolutePathName(Path)
End Function
 
Private Function CreateFolder(ByVal AbsPath$) As Boolean
    'Проверяет путь и при не обходимости создаёт недостающие папки
    '
    Dim f&, j$(), s$, LS$
    CreateFolder = FSO.FolderExists(AbsPath)
    If CreateFolder Then Exit Function
    '---------------
    j = Split(AbsPath, k)
    On Error Resume Next
    For f = 0 To UBound(j)
        s = s & j(f) & k
        If Not FSO.FolderExists(s) And f = 0 Then
            Exit Function 'Драйвер указан не верно
        ElseIf Not FSO.FolderExists(s) Then Call FSO.CreateFolder(s)
            If FSO.FolderExists(s) Then LogWriteLine "CreateFolder", apn(s)
        End If
    Next
    CreateFolder = FSO.FolderExists(AbsPath)
End Function
 
Public Property Let InitDir(ByVal vNewValue As String)
    If FSO.FolderExists(vNewValue) Then
        m_InitDir = FSO.GetAbsolutePathName(vNewValue)
        ChDir m_InitDir: LogWriteLine "InitDir", m_InitDir
    End If
End Property
 
Public Property Let ZipName(ByVal vNewValue As String)
    If LCase(FSO.GetExtensionName(vNewValue)) = "zip" Then
        m_ZipName = FSO.GetAbsolutePathName(vNewValue)
        LogWriteLine "ZipName", m_ZipName
    End If
End Property
 
Public Property Let OutDir(ByVal vNewValue As String)
    m_OutDir = FSO.GetAbsolutePathName(vNewValue)
    LogWriteLine "OutDir", m_OutDir
End Property
 
Private Function GetThreadsList() As Long()
    'Возвращает список потоков
    '
    Dim hSnap&, TE As THREADENTRY32, PID&, Lst&(), u&, i&
    hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0)
    If hSnap = -1 Then Exit Function
    u = 10: i = -1: ReDim Preserve Lst(u)
    TE.dwSize = Len(TE)
    PID = GetCurrentProcessId()
    If Thread32First(hSnap, TE) Then
        Do
            If TE.th32OwnerProcessID = PID Then
                i = i + 1: Lst(i) = TE.th32ThreadID
                If i > u Then u = i * 2: ReDim Preserve Lst(u)
            End If
        Loop While Thread32Next(hSnap, TE)
        ReDim Preserve Lst(i)
    End If
    CloseHandle hSnap
    GetThreadsList = Lst
End Function
 
Public Function UnZip(Parsers()) As Long
    'Извлекает папки/файлы из архива с полной структурой *!
    'совподающие пути заменяются без диалогов
    '
    Dim Zip As Folder3, f&, vEach, oldThreads&(), newThreads&(), hTrd&, DestDir As Object
    Dim j$(), ParserObj As Object, bp$
    LogWriteLine "UnZip"
    On Error Resume Next
    If Not FSO.FileExists(m_ZipName) Then ErrorFO "UnZip": Exit Function
    If Not CreateFolder(m_OutDir) Then ErrorFO "UnZip": Exit Function
    Set Zip = ShellApp.NameSpace(ByVal FSO.GetAbsolutePathName(m_ZipName))
    For Each vEach In Parsers
        j = Split(vEach, k): TrimArrStr (j)
        bp = m_OutDir
        Set ParserObj = Zip
        Set DestDir = ShellApp.NameSpace(ByVal bp)
        For f = 0 To UBound(j)
            Set ParserObj = ParserObj.ParseName(j(f))
            bp = FSO.BuildPath(bp, j(f))
            If ParserObj.IsFolder Then
                If Not CreateFolder(bp) Then GoTo NextEach
                Set ParserObj = ParserObj.GetFolder
                Set DestDir = ShellApp.NameSpace(ByVal bp)
            End If
        Next
        Debug.Print bp
        If FSO.FileExists(bp) Then FSO.DeleteFile (bp)
        If Len(ParserObj.Name) = 0 Then GoTo NextEach
        oldThreads = GetThreadsList
        DestDir.CopyHere ParserObj
        newThreads = GetThreadsList
        If UBound(newThreads) > UBound(oldThreads) Then
            hTrd = OpenThread(SYNCHRONIZE, False, newThreads(UBound(newThreads)))
            Call WaitForSingleObject(hTrd, -1): 'Ждать завершения операции распаковки
        End If
        CloseHandle hTrd
        LogWriteLine "UnZip", vEach: UnZip = UnZip + 1
NextEach:
    Next
    If UnZip = 0 Then ErrorFO "UnZip": Exit Function
End Function
 
Public Function ToZip(Paths()) As Long
    'Создает/добавляет файлы в архив
    '
    Const LenRandName = 10
    Dim Zip As Folder3, f&, oldThreads&(), newThreads&(), hTrd&
    LogWriteLine "ToZip"
    On Error Resume Next
    If Len(m_ZipName) = 0 Then
        Randomize Timer: m_ZipName = Space$(LenRandName)
        For f = 1 To LenRandName: Mid$(m_ZipName, f, 1) = Chr$(97 + Fix(Rnd * 26))
        Next: m_ZipName = m_OutDir & k & m_ZipName & ".zip": GoTo NewZip
    Else
NewZip:
        If Not CreateFile(m_ZipName, "PK" & Chr(5) & Chr(6) & String(18, 0)) Then
            ErrorFO "ToZip": Exit Function
        End If
    End If
    Set Zip = ShellApp.NameSpace(FSO.GetAbsolutePathName(m_ZipName))
    For f = 0 To UBound(Paths)
        Paths(f) = FSO.GetAbsolutePathName(Paths(f))
        If FSO.FileExists(Paths(f)) Or FSO.FolderExists(Paths(f)) Then Else GoTo Next_F
        If GetAttr(Paths(f)) And vbDirectory Then _
        If ShellApp.NameSpace((Paths(f))).Items.Count = 0 Then GoTo Next_F 'Пропускать пустые папки
        'Сравнение старых и новых потоков
        oldThreads = GetThreadsList: Zip.CopyHere ByVal Paths(f): newThreads = GetThreadsList
        If UBound(newThreads) > UBound(oldThreads) Then
            hTrd = OpenThread(SYNCHRONIZE, False, newThreads(UBound(newThreads)))
            Do While WaitForSingleObject(hTrd, 100)  'Ждать завершения операции сжатия
                With ForeGrWinInfo(1)
                    If (.ClassName & .ChildClassName) = "#32770Button" And Len(.ChildText) Then
                        Debug.Print .ChildText, .ClassName, .ChildClassName
                        PostMessage .Child, WM_KEYDOWN, 13, 1
                        Call WaitForSingleObject(hTrd, -1): Exit Do
            End If: End With: Loop
            CloseHandle hTrd
        End If
        LogWriteLine "ToZip", Paths(f): ToZip = ToZip + 1
Next_F:
    Next
    If ToZip = 0 Then ErrorFO "ToZip": Exit Function
End Function
Private Function RelativePath(ByVal Path$) As String
    RelativePath = Replace(Path, m_InitDir & k, "")
End Function
 
Private Function ForeGrWinInfo(Optional ChildID&) As tActCTL
    Dim f&
    With ForeGrWinInfo
        .ForegroundWindow = GetForegroundWindow
        .Child = GetWindow(.ForegroundWindow, GW_CHILD)
        For f = 1 To ChildID: .Child = GetWindow(.Child, GW_HWNDNEXT): Next
        .ClassName = Space$(cc): GetClassName .ForegroundWindow, .ClassName, cc
        .ClassName = Trim$(Left$(.ClassName, InStr(1, .ClassName, vbNullChar) - 1))
        .ChildText = Space$(cc): GetWindowText .Child, .ChildText, cc
        .ChildText = Trim$(Left$(.ChildText, InStr(1, .ChildText, vbNullChar) - 1))
        .ChildClassName = Space$(cc): GetClassName .Child, .ChildClassName, cc
        .ChildClassName = Trim$(Left$(.ChildClassName, InStr(1, .ChildClassName, vbNullChar) - 1))
    End With
End Function
 
 
Public Function Make(Files()) As Long
    'Автокомпиляция проекта
    'Files = Список компилируемых файлов
    Dim FileName$, mDir$, ShellNum&, hProc&, f&
    LogWriteLine "Make"
    If Not CreateFolder(m_OutDir) Then ErrorFO "Make": Exit Function
    mDir = """" & m_OutDir & """"
    For f = 0 To UBound(Files)
        Files(f) = FSO.GetAbsolutePathName(Files(f))
        If Not FSO.FileExists(Files(f)) Then GoTo Next_F
        Select Case LCase(FSO.GetExtensionName(Files(f)))
        Case "vbp", "vbg": Case Else: GoTo Next_F
        End Select: FileName = """" & Files(f) & """"
        ShellNum = Shell(FileVB6_EXE & " /Make " & FileName & " /OutDir " & mDir)
        hProc = OpenProcess(SYNCHRONIZE, False, ShellNum)
        Call WaitForSingleObject(hProc, -1)
        CloseHandle hProc
        Make = Make + 1
Next_F:
    Next
End Function
 
Private Sub Class_Initialize()
    Set FSO = CreateObject("Scripting.FileSystemObject"): LogPath = App.Path & "\LogStream.txt"
    Set LogStream = FSO.CreateTextFile(LogPath)
    LogWriteLine "Initialize" 'Начало ведение лога
    Set ShellApp = CreateObject("Shell.Application")
    FileVB6_EXE = """" & Environ("ProgramFiles") & "\Microsoft Visual Studio\VB98\VB6.EXE" & """"
    m_OldDir = CurDir$: m_OutDir = m_OldDir: m_InitDir = m_OldDir
End Sub
 
Private Sub Class_Terminate()
    ChDir m_OldDir
    LogStream.Close 'Закрытие потока записи лога
End Sub