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

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

  Global gCon As Database
  Global glngNrOfObjects As Long

  Public Property Set DBConn(Con As Database)
          Set gCon = Con
  End Property
 
  Public Property Get DBConn() As Database
          Set DBConn = gCon
  End Property
 
  Private Sub Class_Initialize()
          ‘ эта переменная хранит количество
          ‘ созданных объектов
          glngNrOfObjects = glngNrOfObjects + 1
  End Sub
 
  Private Sub Class_Terminate()
          ‘ уменьшение количества объектов
          glngNrOfObjects = glngNrOfObjects — 1
          ‘ если нет никаких объектов,
          ‘ связь прерывается
          If glngNrOfObjects = 0 Then
              If Not gCon Is Nothing Then
                  gCon.Close
                  Set gCon = Nothing
              End If
          End If
  End Sub

  Dim clsDBConn As Class1
 
  Private Sub Form_Load()
          Set clsDBConn = New Class1
          ‘ связь устанавливается, когда
          ‘ создан первый объект
          If clsDBConn.DBConn Is Nothing Then
              Set clsDBConn.DBConn = Workspaces(0). _
              OpenDatabase(“\VisStudio\Vb98\Biblio.mdb”)
          End If
  End Sub
 
  Private Sub Form_Unload(Cancel As Integer)
          Set clsDBConn = Nothing
  End Sub