Логика регистрации файла

Option Explicit
DefLng F, I, L, N: DefStr J, S
'
'    © FelixMacintosh 2014
'
Const hlpMesage = "" & _
"Команды могут быть с большой или маленькой буквы" & vbCrLf & _
"Также можно вводить несколько команд" & vbCrLf & _
"Список команд:" & vbCrLf & _
"/s [путь к файлу] ; [путь для нового файла] ; [байтовый адрес]" & vbTab & "= Отделить файл" & vbCrLf & _
"/j [главный файл] ; [пришиваемый файл] " & vbTab & "= Объединить два файла" & vbCrLf & _
"/z [путь к zip архиву] ; [путь на диске] " & vbTab & "= Добавить в архив" & vbCrLf & _
"/uz [путь к zip архиву] ; [путь в архиве] ; [папка на диске] " & vbTab & "= Извлеч из архива" & vbCrLf & _
vbTab & "* Примечание папку на диске можно не указывать" & vbCrLf & _
vbTab & "в этом случае это будет текущая папка" & vbCrLf & _
"/r [путь к файлу]" & vbTab & "= Регистрация" & vbCrLf & _
"/u [путь к файлу]" & vbTab & "= Отмена регистрации" & vbCrLf & _
"/cmd [новая комманда отсюда]" & vbTab & "= Любая консольная команда" & vbCrLf & _
"/h или /help " & vbTab & "= Вызов этого сообщения" & vbCrLf & _
"Производство:" & vbCrLf & _
"© FelixMacintosh 2014" & vbTab & "http://vk.com/FelixMacintosh"
'
Private Const Infinite = -1&
Private Const Synchronize = &H100000
Private Const TH32CS_SNAPTHREAD = &H4
'
Private WshShell As Object 'As WshShell '
Private Fso As Object 'As FileSystemObject '
Private mArchive 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 GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId 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 WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Function WaitShell(MyCommand$) As Long
    '
    'Вызов Shell и новой команды, с ожиданием её завершения
    '
    Dim hProc&
    WaitShell = Shell(MyCommand)
    hProc = OpenProcess(Synchronize, False, WaitShell)
    WaitForSingleObject hProc, Infinite
    CloseHandle hProc
End Function
 
Private Sub SS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
    SaveSetting App.EXEName, Section, Key, Setting
End Sub
 
Private Function GS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
    GS = GetSetting(App.EXEName, Section, Key, "")
End Function
 
Private Sub TrimArray(Arr() As String)
    Dim i&
    For i = 0 To UBound(Arr): Arr(i) = Trim(Arr(i)): Next
End Sub
 
Private Sub Main()
    Const r = "/", p = " ", w = ";"
    Dim f, j(), s, j1(), j2(), Start&
    Set WshShell = CreateObject("Shell.Application")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    s = Command$
    j = Split(s, r)
 
    On Error Resume Next: DeleteSetting App.EXEName
    On Error GoTo EndProgramm
 
    For f = 1 To UBound(j)
        j1 = Split(Trim(j(f)), p, 2): TrimArray j1
        '---------
        Select Case LCase(j1(0))
        Case "cmd"
            SS j1(0), WaitShell(j1(1))
        Case "s"
            j2 = Split(j1(1), w): TrimArray j2
            SS j1(0), "Len", WriteBytes(j2(1), ReadBytes(j2(0), CLng(j2(2))), , True)
        Case "j"
            j2 = Split(j1(1), w): TrimArray j2
            Start = Fso.GetFile(j2(0)).Size + 1
            SS j1(0), "Start", Start
            SS j1(0), "Len", WriteBytes(j2(0), ReadBytes(j2(1)), Start) - 1
        Case "uz"
            j2 = Split(j1(1), w): TrimArray j2
            If Fso.FileExists(j2(0)) And LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
                If UBound(j2) = 1 Then
                    ReDim Preserve j2(2): j2(2) = CurDir$
                End If
                Archive = Fso.GetAbsolutePathName(j2(0))
                SS j1(0), UnZipFile(j2(1), j2(2))
            End If
            
        Case "z"
            j2 = Split(j1(1), w): TrimArray j2
            If Fso.FileExists(j2(0)) And LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
                'Используем архив
                Archive = Fso.GetAbsolutePathName(j2(0))
                SS j1(0), CopyPathToArchive(Fso.GetAbsolutePathName(j2(1)))
            ElseIf LCase(Fso.GetExtensionName(j2(0))) = "zip" Then
                'Создаём архив
                CreateArchive Fso.GetAbsolutePathName(j2(0))
                SS j1(0), CopyPathToArchive(Fso.GetAbsolutePathName(j2(1)))
            End If
        Case "r"
            SS j1(0), RegSvr32(j1(1))
        Case "u"
            SS j1(0), RegSvr32(j1(1), True)
        Case "h", "help"
            SS j1(0), MsgBox(hlpMesage)
        Case Else
            'Не выполнена ни одна комманда
        End Select
    Next
EndProgramm:
    '-------------------------Конец программы
    Set WshShell = Nothing
    Set Fso = Nothing
End Sub
 
Private Function CopyHere(Parent, vItem) As Boolean
    '
    'Функция копирования
    'Аргументы: Папка (Zip-папка) // Копируемый объект
 
    Dim f&, Key$, hnd&
    Dim Trd(2) As Collection
    Dim tid As Long, hTrd As Long
    On Error Resume Next
 
    'Получаем список потоков !
    GetThreadsList Trd(0) 'Запомнить старые потоки
    Call Parent.CopyHere((vItem)) 'Копирование >>>>>>>>>>>>
    GetThreadsList Trd(1) 'Запомнить новые потоки
    
    If vItem.Count > 0 Then If Err.Number = 0 Then GoTo 1 'В этом случае ждать не нужно
    
    Err.Clear 'Сброс всех ошибок
 
    Set Trd(2) = New Collection
    For f = Trd(1).Count To 1 Step -1
        Key = "C" & Trd(1).Item(f)
        hnd = Trd(0)(Key)
        If hnd = 0 Then Trd(2).Add CLng(Mid$(Key, 2))
    Next
 
    For f = 1 To Trd(2).Count 'Ожидание открытых потоков
        tid = Trd(2).Item(f)
        hTrd = OpenThread(Synchronize, False, tid)
        WaitForSingleObject hTrd, Infinite
        CloseHandle hTrd
    Next
    CopyHere = True
    Exit Function
1
End Function
 
 
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
 
 
Public Function UnZipFile(ByVal ParseName$, ByVal DestPath$) As Boolean
    '
    'Извлечение из архива
    'Аргументы:
    'DestPath - Путь к папке для распаковки архива
    'ParseName - Путь в архиве
    'Примечание: Имена файлов в архиве, должны быть полными !
    '
    Dim DestDir As Object, Parse As Object
    If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    On Error GoTo 1
    
    If Not Fso.FolderExists(DestPath) Then 'Проверяем есть ли папка
        Fso.CreateFolder (DestPath) 'Создаём папку для перемещаемых туда объектов
    End If
    
    Set DestDir = WshShell.NameSpace((DestPath))
    Set Parse = mArchive.ParseName((ParseName))
    UnZipFile = CopyHere(DestDir, Parse)
    Exit Function
1
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 CopyPathToArchive(ByVal FilePath$) As Boolean
    '
    'Копирует файл / папку в архив
    'Арг: полное имя
    '
    If (mArchive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    If Len(Dir(FilePath, vbDirectory)) > 0 And Len(Dir(FilePath)) = 0 Then
 
        If WshShell.NameSpace((FilePath)).Items.Count = 0 Then
            MsgBox ("Нельзя добавить пустую папку")
            Exit Function
        End If
    End If
    'mArchive.CopyHere (FilePath)
    CopyPathToArchive = CopyHere(mArchive, FilePath) 'Копируем в архив
End Function
 
Public Function CreateArchive(ByVal Рath$) As Boolean
    '
    'Создаёт новый архив
    'Возврат утверждения о создании
    '
    If Fso.FileExists(Рath) Then Kill Рath
    Fso.CreateTextFile(Рath, True).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
    Set mArchive = WshShell.NameSpace((Рath))
    CreateArchive = Not (mArchive Is Nothing) 'Возврат утверждения о создании
End Function
 
 
 
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 = WshShell.NameSpace((vNewValue))
    End If
End Property
 
 
Private Function RegSvr32(Path$, Optional UnReg As Boolean) As Boolean
 
    Dim hProc&, hShell&
    If Fso.FileExists(Path) = False Then Exit Function
    Select Case LCase(Fso.GetExtensionName(Path))
    Case "dll", "ocx"
    Case Else: Exit Function
    End Select
 
    If UnReg Then
        hShell = WshShell("RegSvr32 /s /u " & Path)
    Else
        hShell = WshShell("RegSvr32 /s " & Path)
    End If
 
    hProc = OpenProcess(Synchronize, False, hShell)
    WaitForSingleObject hProc, Infinite
    CloseHandle hProc
    RegSvr32 = True
End Function
 
 
Private Function ReadBytes(FileName$, Optional ByRef Start&, Optional ByVal dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Старт // Длина по умолчанию всего файла
    'Возврат: Массив байт и следующая позиция чтения
    Dim n, f: On Error Resume Next
    f = FreeFile
    Open FileName For Binary As #f
    If Start Then Else Start = 1
    n = LOF(f) - Start + 1
    If dln = 0 Or dln > n Then dln = n
    ReDim Preserve ReadBytes(dln - 1)
    Get #f, Start, ReadBytes: Close #f
    If Err = 0 Then Start = Start + UBound(ReadBytes) + 1
End Function
 
Private Function WriteBytes&(FileName$, Bytes() As Byte, Optional ByVal Start&, _
Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    Dim n, f: On Error Resume Next
    If Start Then Else Start = 1
    f = FreeFile 'Определяем номер свободного файла
    If Overwrite Then Kill FileName
    Open FileName$ For Binary As #f: Put #f, Start, Bytes: Close #f 'Копируем !
    If Err = 0 Then WriteBytes = Start + UBound(Bytes) + 1
End Function

Option Explicit
DefLng F, H-I, L, N: DefStr J, S
'
'    © FelixMacintosh 2014
'
Private Const r = "/", k = "\", p = " ", w = ";", t = "."
Private Const Infinite = -1&
Private Const SYNCHRONIZE = &H100000
Private Const TH32CS_SNAPTHREAD = &H4
'
Private ShellApp As Object 'As Shell '
Private Fso As Object ' As FileSystemObject '
Private TliApp As Object 'As TLIApplication '
Private WshShell As Object
'
Private Archive 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 GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId 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 WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Dim j1(), ID$, bool As Boolean, Start&
Dim Install_log$, System32$
 
Function GetName$(FileName$)
    '
    'Возвращает только имя без папок [\]
    'в формате GetBaseName.GetExtensionName или только GetBaseName
    '
    Dim s$
    GetName = Fso.GetBaseName(FileName)
    s = Fso.GetExtensionName(FileName)
    If Len(s) Then GetName = GetName & t & s
 
End Function
 
Function GUID$(FileName$, Optional HelpDir$)
    On Error Resume Next
    GUID = TliApp.TypeLibInfoFromFile(GetName(FileName)).GUID
    HelpDir = WshShell.RegRead("HKEY_CLASSES_ROOT\TypeLib\" & GUID & "\1.0\HELPDIR\")
End Function
 
Function ResReg(ByVal AbsPath$, Class$) As Object
    '
    'Внутренняя функция для обеспечения работы программы
    'Проверка, извлечение DLL из ресурса, регистрация
    'и возврат ссылки на указанный класс этого объекта
    '
    Dim f&, j$()
    On Error Resume Next
    For f = 0 To 1
        Err.Clear
        Set ResReg = CreateObject(Class)
        If Err Then
            If Not Fso.FileExists(AbsPath) Then
                j = Split(GetName(AbsPath), t)
                If Not CreateFile(AbsPath, True, LoadResData(j(0), j(1))) Then
                    Exit For 'Если файл не мог создасьться то выход
                End If
            End If
            RegSvr32 AbsPath 'Регистрация
        Else: Exit For
        End If
    Next
    
End Function
 
Sub Main()
    Dim f&, ListComands$(), s$, j$()
 
    Set ShellApp = CreateObject("Shell.Application")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set WshShell = CreateObject("WScript.Shell")
    System32 = Fso.GetParentFolderName(Environ("ComSpec"))
    Set TliApp = ResReg(System32 & k & App.EXEName & "\TLBINF32.DLL", "TLI.TLIApplication")
 
    On Error Resume Next
    'Проверка на наличие файла Install.log (создание его)
    Install_log = System32 & k & App.EXEName & "\Install.Log"
    CreateFile Install_log
    
    DeleteSetting App.EXEName
 
    s = Command$
    ListComands = Split(s, r): TrimArray ListComands
    For f = 1 To UBound(ListComands)
        j = Split(ListComands(f), p, 2): TrimArray j
        '---------
        Select Case LCase(j(0))
        Case "cmd": com_cmd j
        Case "s": com_s j
        Case "j": com_j j
        Case "uz", "uz+": com_uz j
        Case "z": com_z j
        Case "r", "r+": com_r j
        Case "u", "u+": com_u j
        Case "h", "help": com_h j
        Case Else
            'Не выполнена ни одна комманда
        End Select
    Next
    '-------------------------Конец программы
    Set ShellApp = Nothing
    Set Fso = Nothing
    Set TliApp = Nothing
 
End Sub
 
Sub com_h(j())
    SS j(0), MsgBox(LoadResString(101))
End Sub
 
Sub com_u(j())
    SS j(0), "GUID", RegSvr32(j(1), False)
End Sub
 
Sub com_r(j())
    Dim h$
    ID = GUID(j(1), h)
    If j(0) = "r+" And Len(ID) Then
        SS j(0), "GUID", ID
    Else
        ID = RegSvr32(j(1))
        If Len(ID) Then 'Запись о зарегестрированном файле
            CreateFile Install_log, False, vbCrLf & ID, Fso.GetFile(Install_log).Size + 1
        End If
        SS j(0), "GUID", ID
    End If
End Sub
 
Sub com_z(j())
    j1 = Split(j(1), w): TrimArray j1
    If Fso.FileExists(j1(0)) And LCase(Fso.GetExtensionName(j1(0))) = "zip" Then
        'Используем архив
        Set Archive = ShellApp.NameSpace((Fso.GetAbsolutePathName(j1(0))))
        SS j(0), CopyPathToArchive(Fso.GetAbsolutePathName(j1(1)))
    ElseIf LCase(Fso.GetExtensionName(j1(0))) = "zip" Then
        'Создаём архив
        CreateArchive Fso.GetAbsolutePathName(j1(0))
        SS j(0), CopyPathToArchive(Fso.GetAbsolutePathName(j1(1)))
    End If
End Sub
 
Sub com_uz(j())
    j1 = Split(j(1), w): TrimArray j1
    If Fso.FileExists(j1(0)) And LCase(Fso.GetExtensionName(j1(0))) = "zip" Then
        If UBound(j1) = 1 Then
            ReDim Preserve j1(2): j1(2) = CurDir$
        End If
        Set Archive = ShellApp.NameSpace((Fso.GetAbsolutePathName(j1(0))))
        SS j(0), UnZipFile(j1(1), j1(2))
    End If
End Sub
 
Sub com_j(j())
    j1 = Split(j(1), w): TrimArray j1
    Start = Fso.GetFile(j1(0)).Size + 1
    SS j(0), "Start", Start
    SS j(0), "Len", WriteBytes(j1(0), ReadBytes(j1(1)), Start) - 1
End Sub
 
Sub com_s(j())
    j1 = Split(j(1), w): TrimArray j1
    SS j(0), "Len", WriteBytes(j1(1), ReadBytes(j1(0), CLng(j1(2))), , True)
End Sub
 
Sub com_cmd(j())
    SS j(0), WaitShell(j(1))
End Sub
 
Function CreateFile(ByVal AbsPath$, Optional Overwrite As Boolean, Optional vBytes, Optional ByRef Start&) As Boolean
    '
    'Проверяет путь и при не обходимости создаёт вложенные папки и файл
    'Арг: Абсолютный путь // True = перезапись // Данные // ByRef Начальная позиция записи
    '
    Dim f&, j$(), s$, byt() As Byte, bit As Boolean
    bit = Fso.FileExists(AbsPath)
    If bit And Overwrite Then
        s = AbsPath: GoTo WriteFile
    ElseIf bit Then
        GoTo WriteFile
    End If
    '------------------------
    j = Split(AbsPath, k)
    On Error GoTo EndFunction
    For f = 0 To UBound(j) - 1
        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)
        End If
    Next
WriteFile:
    s = TypeName(vBytes)
    Select Case s
    Case "String", "Byte()" 'Если в переменной vBytes правильные данные, то ...
        'Конвертировать данные в байтовый массив
        If s = "String" Then byt = StrConv(vBytes, vbFromUnicode) Else byt = vBytes
        Start = WriteBytes(AbsPath, byt, Start, Overwrite) 'Копируем эти данные
        Erase byt 'Уничтожить массив для высвобождения памяти
    Case Else
        'Если файла не существует, то...
        If bit = False Then Call WriteBytes(AbsPath, byt, 0, False) 'Создаём пустой файл 0 байт
    End Select
    CreateFile = Fso.FileExists(AbsPath) 'Получаем бит утверждения что файл на месте
    
EndFunction:
End Function
 
Function CreateFolder(ByVal AbsPath$) As Boolean
    '
    'Проверяет путь и при не обходимости создаёт недостающие папки
    '
    Dim f&, j$(), s$
    CreateFolder = Fso.FolderExists(AbsPath)
    If CreateFolder Then Exit Function
    '---------------
    j = Split(AbsPath, k)
    On Error GoTo 1
    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)
        End If
    Next
    CreateFolder = Fso.FolderExists(AbsPath)
1
End Function
 
Function WaitShell(MyCommand$) As Long
    '
    'Вызов Shell и новой команды, с ожиданием её завершения
    '
    Dim hProc&
    WaitShell = Shell(MyCommand)
    hProc = OpenProcess(SYNCHRONIZE, False, WaitShell)
    WaitForSingleObject hProc, Infinite
    CloseHandle hProc
End Function
 
Sub SS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
    SaveSetting App.EXEName, Section, Key, Setting
End Sub
 
Function GS(ByVal Section$, ByVal Key$, Optional ByVal Setting$ = "0")
    GS = GetSetting(App.EXEName, Section, Key, "")
End Function
 
Sub TrimArray(Arr() As String)
    Dim f&
    For f = 0 To UBound(Arr): Arr(f) = Trim(Arr(f)): Next
End Sub
 
Function CopyHere(Parent, vItem) As Boolean
    '
    'Функция копирования
    'Аргументы: Папка (Zip-папка) // Копируемый объект
 
    Dim f&, Key$, hnd&
    Dim Trd(2) As Collection
    Dim tid As Long, hTrd As Long
    On Error Resume Next
 
    'Получаем список потоков !
    GetThreadsList Trd(0) 'Запомнить старые потоки
    Call Parent.CopyHere((vItem)) 'Копирование >>>>>>>>>>>>
    GetThreadsList Trd(1) 'Запомнить новые потоки
 
    If vItem.Count > 0 Then If Err.Number = 0 Then GoTo 1 'В этом случае ждать не нужно
 
    Err.Clear 'Сброс всех ошибок
 
    Set Trd(2) = New Collection
    For f = Trd(1).Count To 1 Step -1
        Key = "C" & Trd(1).Item(f)
        hnd = Trd(0)(Key)
        If hnd = 0 Then Trd(2).Add CLng(Mid$(Key, 2))
    Next
 
    For f = 1 To Trd(2).Count 'Ожидание открытых потоков
        tid = Trd(2).Item(f)
        hTrd = OpenThread(SYNCHRONIZE, False, tid)
        WaitForSingleObject hTrd, Infinite
        CloseHandle hTrd
    Next
    CopyHere = True
    Exit Function
1
End Function
 
 
Sub GetThreadsList(List As Collection)
    '
    '   Возвращает List с коллекцией потоков
    '
    Dim hSnap&, TE As THREADENTRY32, PID&
    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
 
 
Function UnZipFile(ByVal ParseName$, ByVal DestPath$) As Boolean
    '
    'Извлечение из архива
    'Аргументы:
    'DestPath - Путь к папке для распаковки архива
    'ParseName - Путь в архиве
    'Примечание: Имена файлов в архиве, должны быть полными !
    '
    Dim DestDir As Object, Parse As Object
    If (Archive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    On Error GoTo 1
 
    If Not Fso.FolderExists(DestPath) Then 'Проверяем есть ли папка
        Fso.CreateFolder (DestPath) 'Создаём папку для перемещаемых туда объектов
    End If
 
    Set DestDir = ShellApp.NameSpace((DestPath))
    Set Parse = Archive.ParseName((ParseName))
    UnZipFile = CopyHere(DestDir, Parse)
    Exit Function
1
End Function
 
Function ArchivePath$(Optional ByVal ind&)
    '
    'Возврат имени файла в архиве
    'Ind - номер файла в архиве (начало с 0), по умолчанию - 0
    '
    If (Archive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    On Error Resume Next
    ArchivePath = Archive.Items().Item((ind)).Рath
End Function
 
Function CopyPathToArchive(ByVal FilePath$) As Boolean
    '
    'Копирует файл / папку в архив
    'Арг: полное имя
    '
    If (Archive Is Nothing) Then Exit Function 'Проверяем указан ли архив ?
    If Len(Dir(FilePath, vbDirectory)) > 0 And Len(Dir(FilePath)) = 0 Then
 
        If ShellApp.NameSpace((FilePath)).Items.Count = 0 Then
            MsgBox ("Нельзя добавить пустую папку")
            Exit Function
        End If
    End If
    CopyPathToArchive = CopyHere(Archive, FilePath) 'Копируем в архив
End Function
 
Function CreateArchive(ByVal AbsPath$) As Boolean
    '
    'Создаёт новый архив
    'Возврат утверждения о создании
    'Арг: полное имя
    '
    CreateFile AbsPath, True, "PK" & Chr(5) & Chr(6) & String(18, 0)
    Set Archive = ShellApp.NameSpace((AbsPath))
    CreateArchive = Not (Archive Is Nothing) 'Возврат утверждения о создании
End Function
 
Function RegSvr32(ByVal Path$, Optional Reg As Boolean = True) As String
    '
    'Возвращает GUID
    'Арг: Зарегить/Отменить регистрацию
    '
    Dim hProc&, hShell&, Path34$
    
    Path = Replace(Path, Chr(34), vbNullString)
    If Len(Path) Then Path34 = Chr(34) & Path & Chr(34)
    If Fso.FileExists(Path) = False Then Exit Function
    Select Case LCase(Fso.GetExtensionName(Path))
    Case "dll", "ocx"
    Case Else: Exit Function
    End Select
    If Reg Then
        hShell = Shell("RegSvr32 " & Path34) 'Зарегить
'        hShell = Shell("RegSvr32 /s " & Path34) 'Зарегить тихий режим
    Else
        hShell = Shell("RegSvr32 /u " & Path34) 'Отменить
'        hShell = Shell("RegSvr32 /s /u " & Path34) 'Отменить тихий режим
    End If
    hProc = OpenProcess(SYNCHRONIZE, False, hShell)
    WaitForSingleObject hProc, Infinite
    CloseHandle hProc
    RegSvr32 = GUID(Path)
End Function
 
 
Function ReadBytes(FileName$, Optional ByRef Start&, Optional ByVal dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Старт // Длина по умолчанию всего файла
    'Возврат: Массив байт и следующая позиция чтения
    Dim n&, f&: On Error Resume Next
    f = FreeFile
    Open FileName For Binary As #f
    If Start Then Else Start = 1
    n = LOF(f) - Start + 1
    If dln = 0 Or dln > n Then dln = n
    ReDim Preserve ReadBytes(dln - 1)
    Get #f, Start, ReadBytes: Close #f
    If Err = 0 Then Start = Start + UBound(ReadBytes) + 1
End Function
 
Function WriteBytes&(FileName$, Bytes() As Byte, Optional ByVal Start&, _
Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    Dim n&, f&: On Error Resume Next
    If Start Then Else Start = 1
    f = FreeFile 'Определяем номер свободного файла
    If Overwrite Then Kill FileName
    Open FileName$ For Binary As #f: Put #f, Start, Bytes: Close #f 'Копируем !
    If Err = 0 Then WriteBytes = Start + UBound(Bytes) + 1
End Function