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

            j2 = Split(j1(1), w): TrimArray j2
            SS j1(0), "Len", WriteBytes(j2(1), ReadBytes(j2(0), CLng(j2(2))), , True)

Private Const r = "/", p = " ", w = ";", t = "\"
 
Function CreateFile(ByVal AbsPath$, Optional Overwrite As Boolean) As Boolean
    '
    'Проверяет путь и при не обходимости создаёт недостающие папки и файл
    '
    Dim f&, j$(), s$
    If Fso.FileExists(AbsPath) And Overwrite Then
        Fso.CreateTextFile (AbsPath)
        CreateFile = True
        Exit Function
    ElseIf Fso.FileExists(AbsPath) Then
        CreateFile = True
        Exit Function
    End If
    '------------------------
    j = Split(AbsPath, t)
    On Error GoTo 1
    For f = 0 To UBound(j) - 1
        s = s & j(f) & t
        If Not Fso.FolderExists(s) And f = 0 Then
            Exit Function 'Драйвер указан не верно
        ElseIf Not Fso.FolderExists(s) Then
            Call Fso.CreateFolder(s)
        End If
    Next
    
    Fso.CreateTextFile (s & j(f))
    CreateFile = True
1
End Function
 
Function CreateFolder(ByVal AbsPath$) As Boolean
    '
    'Проверяет путь и при не обходимости создаёт недостающие папки
    '
    Dim f&, j$(), s$
    CreateFolder = Fso.FolderExists(AbsPath)
    If CreateFolder Then Exit Function
    '---------------
    j = Split(AbsPath, t)
    On Error GoTo 1
    For f = 0 To UBound(j)
        s = s & j(f) & t
        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(s)
1
End Function

Sub Primer()
    ' добавляем ключ лицензии для FlexGrid Control 6.0
    CreateObject("WScript.Shell").RegWrite _
    "HKEY_CLASSES_ROOT\Licenses\72E67120-5959-11cf-91F6-C2863C385E30", _
    "ibcbbbebqbdbciebmcobmbhifcmciibblgmf", "REG_SZ"
End Sub

Option Explicit
 
Type GUID
    B(16) As Byte
End Type
Declare Function GetClassFile Lib "Ole32.DLL" (ByVal lpszFileName As String, ByRef pclsid As GUID) As Long
Declare Function StringFromGUID2 Lib "Ole32.DLL" (ByRef rguid As GUID, ByVal lpsz As String, ByVal cbMax As Long) As Long
Public Declare Function GetCLSID6 Lib "VB6STKIT.DLL" Alias "GetClsidFromActXFile" (ByVal pszFilename As String, ByVal pszProgID As String, ByVal pszClsid As String) As Long
 
'Sub Main()
'    Dim s$
'    s = InputBox("Введите имя своей DLL на примере ниже..", , "C:\Windows\system32\shell32.dll")
'    MsgBox "GUID = " & GetCLSID(s)
'End Sub
 
Private Sub Form_Load()
    Dim s$
    s = InputBox("Введите имя своей DLL на примере ниже..", , "C:\Windows\system32\shell32.dll")
    MsgBox "GUID = " & GetCLSID(s)
End Sub
 
Function GetCLSID(FileName As String) As String
    Dim g As GUID
    Dim RetVal As Long
    Dim strGUID As String
    Dim MyProgID As String
    RetVal = GetClassFile(StrConv(FileName, vbUnicode), g)
    strGUID = Space(255)
    RetVal = StringFromGUID2(g, strGUID, 255)
    strGUID = StrConv(strGUID, vbFromUnicode)
 
    If (InStr(strGUID, Chr(0)) > 0) Then
        strGUID = Left(strGUID, InStr(strGUID, Chr(0)) - 1)
    End If
    RetVal = GetCLSID6(CStr(FileName), MyProgID, strGUID)
    GetCLSID = strGUID
End Function

Option Explicit
 
Sub Main()
    Dim s$
    s = InputBox("Введите имя своей DLL на примере ниже..", , "shell32.dll")
    MsgBox "GUID = " & CLSIDFromFile(s)
End Sub
 
'Private Sub Form_Load()
'    Dim s$
'    s = InputBox("Введите имя своей DLL на примере ниже..", , "shell32.dll")
'    MsgBox "GUID = " & CLSIDFromFile(s)
'End Sub
 
Public Function CLSIDFromFile(sFile As String) As String
   Dim tliapp As Object
   Dim tli As Object
   On Error GoTo Out
    Set tliapp = CreateObject("TLI.TLIApplication")
   Set tli = tliapp.TypeLibInfoFromFile(sFile)
   CLSIDFromFile = tli.GUID
Out:
 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 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, byt() As Byte, start&
Dim Install_log$
 
Function GUID$(ByVal FileName$)
    On Error Resume Next
    FileName = Fso.GetBaseName(FileName) & t & Fso.GetExtensionName(FileName)
    GUID = tliapp.TypeLibInfoFromFile(FileName).GUID
End Function
 
Sub MAIN()
    Dim f&, ListComands$(), s$, j$(), j1$()
    
    Set ShellApp = CreateObject("Shell.Application")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set tliapp = CreateObject("TLI.TLIApplication")
 
    'Проверка на наличие файла Install.log (создание его)
    Install_log = Fso.GetParentFolderName(Environ("ComSpec"))
    Install_log = Install_log & k & App.EXEName & k & "Install.Log"
    CreateFile Install_log
 
    On Error Resume Next
    DeleteSetting App.EXEName
 
    s = Command$
    ListComands = Split(s, r)
    For f = 1 To UBound(ListComands)
        j = Split(Trim(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), RegSvr32(j(1), True)
End Sub
 
Sub com_r(j())
    ID = GUID(j(1))
    If j(0) = "r+" And Len(ID) Then
        SS j(0), "GUID", ID
    Else
        ID = RegSvr32(j(1))
        If Len(ID) Then 'Запись о зарегестрированном файле
            byt = StrConv(vbCrLf & ID, vbFromUnicode)
            WriteBytes Install_log, byt, Fso.GetFile(Install_log).Size + 1
        End If
        SS j(0), 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) As Boolean
    '
    'Проверяет путь и при не обходимости создаёт недостающие папки и файл
    '
    Dim f&, j$(), s$
    If Fso.FileExists(AbsPath) And Overwrite Then
        Fso.CreateTextFile (AbsPath)
        CreateFile = True
        Exit Function
    ElseIf Fso.FileExists(AbsPath) Then
        CreateFile = True
        Exit Function
    End If
    '------------------------
    j = Split(AbsPath, k)
    On Error GoTo 1
    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
 
    Fso.CreateTextFile (s & j(f))
    CreateFile = True
1
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(s)
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
    '
    'Создаёт новый архив
    'Возврат утверждения о создании
    'Арг: полное имя
    '
    If Fso.FileExists(AbsPath) Then Kill AbsPath
    Fso.CreateTextFile(AbsPath, True).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
    Set Archive = ShellApp.NameSpace((AbsPath))
    CreateArchive = Not (Archive Is Nothing) 'Возврат утверждения о создании
End Function
 
Function RegSvr32(Path$, Optional Reg As Boolean = True) As String
    '
    'Возвращает GUID
    'Арг: Зарегить/Отменить регистрацию
    '
    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 Reg Then
        hShell = Shell("RegSvr32 /s " & Path) 'Зарегить
    Else
        hShell = Shell("RegSvr32 /s /u " & Path) 'Отменить
    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