Надежный хостинг с очень длительным хранением файлов

Option Explicit
'
'   © Антихакер32™ Нативная DLL создаваемая по необходимости +Стильная иконка
'   И пример использования модуля SubClass
'   P.S Ничего устанавливать не нужно, требуется пустая форма
'
Const HTCAPTION = 2
Const WM_MOVE = &H3
Const WM_SIZE = &H5
Const WM_LBUTTONDOWN = &H201
Const WM_NCLBUTTONDOWN = &HA1
Dim WithEvents tx1 As TextBox
Dim WithEvents cm1 As CommandButton
Dim WithEvents cm2 As CommandButton
 
Private Declare Function Hooks Lib "MHook.dll" () As Object
'Экспортируемые функции
'Function AddChildHook(Child As Object, ByVal ParentProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от дочернего контрола
'    'Арг: Дочерний объект// вызываемое имя отцовой процедуры // сообщения окна
'    '
'Function AddParentHook(Child As Object, ByVal ChildProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от родительского окна
'    'Арг: Дочерний объект// вызываемое имя дочерней процедуры // сообщения окна
'    '
'Function AddHook(Obj As Object, ByVal ProcName$, ByVal Message&) As Long
'    'Добавление хука для отлова сообщений от указанного окна
'    'Арг: Объект// вызываемое имя процедуры // сообщения окна
'    '
'Function CloseHook(ByVal hwnd&) As Long
'    'Закрывает все хуки связанные с этим окном
'    'После этого можно останавливать программу
'    '
'Function CloseAllHooks() As Long
'    'Закрывает все ранее открытые хуки, и возвращает их число
    '
 
Dim h&, h1&
Dim mHooks As Object
 
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef IpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
 
Function CheckFiles(ByVal ZipUrl$, ByVal Folder$, ParamArray ParseNames()) As Long
    'Проверяет наличие файлов, указанных в аргументах ParseNames
    'И при необходимости докачивает их в указанную папку Folder
    'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
    '© Антихакер32™  ...2014
    '
    Const Promt0 = "Отсутствуют необходимые компоненты" & vbCrLf
    Const Promt1 = Promt0 & "Отсутствует соединение с интернетом, для того чтоб их скачать"
    Const Promt2 = Promt0 & "Указанный URL не является ZIP-папкой с компонентами"
    Const Promt3 = Promt0 & "URL Zip-папки, не указан"
    Dim vEach, OldDir$, ArcName$, f&, zExists As Boolean, s$, i&, b() As Byte
    Dim ShellApp As Object, Fso As Object, Zip As Object
    Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
    If Fso.FolderExists(Folder) Then ChDir Folder Else Folder = OldDir
    For Each vEach In ParseNames
        If Fso.FileExists(vEach) Or Fso.FolderExists(vEach) Then
            CheckFiles = CheckFiles + 1: GoTo NextEach
        ElseIf Len(ZipUrl) Then On Error Resume Next
            If Not zExists Then 'Обращение к интернету и закачка необходимых файлов
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                With CreateObject("MSXML2.XMLHTTP")
                    .Open "GET", ZipUrl, False '--или--.Open "GET", ZipUrl, False, Имя, Пароль
                    .send: s = LCase(Split(.getResponseHeader("Content-Type"), "/")(1))
                    If s <> "zip" Then MsgBox Promt2, vbInformation: End
                    ArcName = .getResponseHeader("Content-disposition")
                    b = .responseBody: .abort 'Завершить соединение
                End With
                i = InStr(1, ArcName, "filename=") + 10: ArcName = Mid$(ArcName, i, Len(ArcName) - i)
                f = FreeFile: Open ArcName For Binary As #f: Put #f, 1, b: Close #f 'Копирование байт
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName))
            End If: 'On Error GoTo 0
            If Zip.ParseName((vEach)) Is Nothing Then GoTo NextEach
            ShellApp.NameSpace((Folder)).CopyHere Zip.ParseName((vEach))
            f = FreeFile: Open CStr(vEach) For Binary As #f: ReDim b(LOF(f) - 1)
            Do: DoEvents: s = b: Get #f, 1, b: Sleep 100: Loop While s <> CStr(b) 'пока есть разница данных
            Close #f: CheckFiles = CheckFiles + 1 'Файл из архива успешно скопирован, переход к следующему файлу
        Else: MsgBox Promt3, vbInformation: End
        End If
NextEach:
    Next: If Folder <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
    If Len(ArcName) Then Kill ArcName
End Function
 
Private Sub Form_Load()
    Dim c(1) As CommandButton, f&
    Call CheckFiles( _
    "https://www.cyberforum.ru/blog_attachment.php?attachmentid=2468&d=1402890085" _
    , "", "MHook.dll", "PlasticFantastic Icon 13.ico")
    '-------------------------------------------------------------
    Me.Icon = LoadPicture("PlasticFantastic Icon 13.ico")
    Set mHooks = Hooks 'Загружаем класс
    
    Set tx1 = Controls.Add("vb.TextBox", "tx1")
    tx1.Move 100, 100, 4000, 500: tx1.Text = "Сдвинь меня !, и посмотри на стильную иконку"
    tx1.Visible = 1
    Set c(0) = Controls.Add("vb.CommandButton", "cm1")
    Set c(1) = Controls.Add("vb.CommandButton", "cm2")
    For f = 0 To 1: c(f).Move 100, 100 + (500 * f), 1500, 500
        c(f).Visible = 1: c(f).Caption = Choose(f + 1, "Закрыть хук", "Активировать хук")
    Next
    Set cm1 = c(0): Set cm2 = c(1)
    h1 = mHooks.AddHook(Me, "WMove", WM_MOVE)
End Sub
 
Private Sub cm2_Click()
    h1 = mHooks.AddChildHook(tx1, "TXMove", WM_LBUTTONDOWN)
End Sub
 
Private Sub cm1_Click()
    mHooks.CloseHook h1
End Sub
 
Public Function WMove(ParamArray Arg())
    Debug.Print Me.Left, Me.Top
End Function
 
Public Function TXMove(ParamArray Arg())
    Arg(2) = WM_NCLBUTTONDOWN
    Arg(3) = HTCAPTION
    TXMove = 1
End Function