Как скачать файл с rghost? - VB
Формулировка задачи:
Не качает с rghost
качает только по прямым ссылкам с расширением и полным путем к файлу например www.test.ru/1.exe
Решение задачи: «Как скачать файл с rghost?»
textual
Листинг программы
Option Explicit
'
' © Антихакер32™ ..2014
'
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
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
'Если папка не указанна, то отсутствующие файлы будут скопированны в текущую папку
'
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, Zip As Object, Rect As Rect, MinWin&, Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject"): OldDir = CurDir$
If Fso.FolderExists(Folder) Then ChDir Fso.GetAbsolutePathName(Folder) Else ChDir App.Path
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 'Обращение к интернету и закачка необходимых файлов
GetWindowRect GetDesktopWindow, Rect 'Маленькая надпись
MinWin = CreateWindowEx(0&, "STATIC", ">>--- Загрузка ---<<", &H50800000, _
(Rect.Right - 150) / 2, (Rect.Bottom - 20) / 2, 150, 20, GetDesktopWindow, 0&, 0, ByVal 0&)
'
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 & "_": Randomize Timer 'Добавление своих цифр
For f = 1 To 10: ArcName = ArcName & Fix(Rnd * 10): 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((CurDir$)).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 Len(ArcName) Then Kill ArcName
If MinWin Then DestroyWindow MinWin
If CurDir$ <> OldDir Then ChDir OldDir 'Если папка была изменена, то возврат в прежнюю папку
End Function