Скачивание файлов с HTTP-ресурса

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
    ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long _
    ) As Long
 
Private Sub Command1_Click()
 
    HomeDir$ = App.Path
    
    HomeUrl$ = Me.Text1.Text
    
    p% = InStrRev(HomeUrl$, "/")
    
    HomeUrl$ = Left$(HomeUrl$, p% - 1)
    
    URLDownloadToFile 0, Me.Text1.Text, HomeDir$ + "\111.111", 0, 0
 
    Me.List1.Clear
    
    fi% = FreeFile
    
    Open HomeDir$ + "\111.111" For Binary Access Read As #fi%
    
    LF& = LOF(fi%)
    
    Buf$ = Space$(LF&)
    
    Get #fi%, , Buf$
    
    Close #fi%
    
    ppp& = InStr(Buf$, "alt=""[   ]""")
    
    Do
       
       b& = InStr(ppp&, Buf$, "<a href=")
       
       If b& = 0 Then Exit Do
              
       e& = InStr(b& + 1, Buf$, ">")
       
       fnam$ = Mid$(Buf$, b& + 9, e& - b& - 10)
              
       Me.List1.AddItem fnam$
        
       ppp& = e& + 1
        
    Loop
 
End Sub
 
Private Sub Command2_Click()
 
    HomeDir$ = App.Path
    
    HomeUrl$ = Me.Text1.Text
    
    p% = InStrRev(HomeUrl$, "/")
    
    HomeUrl$ = Left$(HomeUrl$, p% - 1)
    
    For i% = 0 To Me.List1.ListCount - 1
    
        If Me.List1.Selected(i%) Then
        
           fnam$ = Me.List1.List(i%)
           
           URLDownloadToFile 0, HomeUrl$ + "/" + fnam$, HomeDir$ + "/" + fnam$, 0, 0
        
           Me.List1.Selected(i%) = False
        
           DoEvents
        
        End If
        
    Next i%
 
    MsgBox "OK!"
 
End Sub
 
Private Sub Command3_Click()
    Unload Me
End Sub

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 Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) 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 'Обращение к интернету и закачка необходимых файлов
                i = Len(ZipUrl): ArcName = ZipUrl
                For f = 1 To i: If Mid$(ArcName, f, 1) Like "[!0-9!A-Z!a-z]" Then Mid$(ArcName, f, 1) = "_"
                Next: ArcName = ArcName & ".zip"
                If InternetGetConnectedState(0&, 0&) = 0 Then MsgBox Promt1, vbInformation: End
                If URLDownloadToFile(0, ZipUrl, ArcName, 0, 0) Then MsgBox Promt3, vbInformation: End
                Set ShellApp = CreateObject("Shell.Application")
                Set Zip = ShellApp.NameSpace(Fso.GetAbsolutePathName(ArcName)): zExists = Zip.Items.Count
                If Not zExists Then MsgBox Promt2, vbInformation: Kill ArcName: End
            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: 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