Как скачать файл с rghost?

Option Explicit
Global Const r = "/", z = ",", k = "\", NameFilter = "[!0-9!a-z!A-Z!а-я!А-Я!Ё!ё!_]"
Dim clsSInst As New clsSInst
 
Sub CallArg(ByVal ArgLine As String)
    Dim f&, J$(1), Arg(), Result As Variant
    On Error Resume Next
    For f = 1 To Len(ArgLine):  If Mid$(ArgLine, f, 1) Like NameFilter Then Exit For
        J(0) = J(0) & Mid$(ArgLine, f, 1)
    Next: J(1) = Trim(Mid$(ArgLine, f))
    If Asc(J(1)) = Asc("=") Then
        Result = CallByName(clsSInst, J(0), VbLet, Trim$(Mid$(J(1), 2)))
    Else
        Arg = TrimArrVar(Split(J(1), z))
        Result = CallByName(clsSInst, J(0), VbMethod, Arg)
        If Err.Number = 450 Then
            Result = CallByName(clsSInst, J(0), VbLet, Arg(0))
            Exit Sub
        End If
    End If
End Sub
 
Sub Main()
    Dim Arg() As Variant, J$(), f&, u&
 
    '----------------------------------
    On Error Resume Next: DeleteSetting App.Path
    On Error GoTo 0
    J = TrimArrStr(Split(Command$, r))
    For f = 0 To UBound(J):  If Len(J(f)) Then CallArg J(f)
    Next
 
End Sub
 
Function TrimArrVar(Arr) As Variant()
    'Удаляет передние и задние пробелы в массиве
    '
    Dim f&: ReDim v(UBound(Arr)): For f = 0 To UBound(Arr): v(f) = Trim(Arr(f)): Next: TrimArrVar = v
    TrimArrVar = v
End Function
 
Function TrimArrStr(Arr) As String()
    'Удаляет передние и задние пробелы в списке
    '
    Dim f&, J$(): J = Arr: For f = 0 To UBound(Arr): J(f) = Trim(Arr(f)): Next: TrimArrStr = J
End Function

Option Explicit
 
Const TH32CS_SNAPTHREAD = &H4
Const SYNCHRONIZE = &H100000
'
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 OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds 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 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'
Dim FSO As FileSystemObject ' Object
Dim ShellApp As Shell, LogStream As TextStream, LogStreamRead As TextStream
'
Dim FileVB6_EXE$, m_OutDir$, m_ZipName$, m_InitDir$, OldDir$
 
Public Function CreateFolder(ByVal AbsPath$) As Boolean
    'Проверяет путь и при не обходимости создаёт недостающие папки
    '
    Dim f&, J$(), S$, LS$
    CreateFolder = FSO.FolderExists(AbsPath)
    If CreateFolder Then Exit Function
    '---------------
    J = Split(AbsPath, k)
    On Error GoTo Errr
    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): LS = S
        End If
    Next
    CreateFolder = FSO.FolderExists(AbsPath)
    If Len(LS) Then LogStream.WriteLine Now & "[CreateFolder]" & FSO.GetAbsolutePathName(LS)
Errr:
End Function
 
 
Public Property Let InitDir(ByVal vNewValue As String)
    If FSO.FolderExists(vNewValue) Then
        m_InitDir = FSO.GetAbsolutePathName(vNewValue)
        ChDir m_InitDir
        LogStream.WriteLine Now & "[InitDir]" & m_InitDir
    End If
End Property
 
Public Property Let ZipName(ByVal vNewValue As String)
    If LCase(FSO.GetExtensionName(vNewValue)) = "zip" Then
        m_ZipName = FSO.GetAbsolutePathName(vNewValue)
        LogStream.WriteLine Now & "[ZipName]" & m_ZipName
    End If
End Property
 
Public Property Let OutDir(ByVal vNewValue As String)
    m_OutDir = FSO.GetAbsolutePathName(vNewValue)
    LogStream.WriteLine Now & "[OutDir]" & m_OutDir
End Property
 
Function GetThreadsList() As Long()
    'Возвращает список потоков
    '
    Dim hSnap&, TE As THREADENTRY32, PID&, Lst&(), u&, i&
    hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0)
    If hSnap = -1 Then Exit Function
    u = 10: i = -1: ReDim Preserve Lst(u)
    TE.dwSize = Len(TE)
    PID = GetCurrentProcessId()
    If Thread32First(hSnap, TE) Then
        Do
            If TE.th32OwnerProcessID = PID Then
                i = i + 1: Lst(i) = TE.th32ThreadID
                If i > u Then u = i * 2: ReDim Preserve Lst(u)
            End If
        Loop While Thread32Next(hSnap, TE)
        ReDim Preserve Lst(i)
    End If
    CloseHandle hSnap
    GetThreadsList = Lst
End Function
 
 
Public Function ToZip(Paths()) As Long
    Const LenRandName = 10
    Dim Zip As Folder3, Path$, f&, oldThreads&(), newThreads&(), hTrd&
    LogStream.WriteLine Now & "[ToZip]"
    If Len(m_ZipName) = 0 Then
        Randomize Timer: m_ZipName = Space$(LenRandName)
        For f = 1 To LenRandName: Mid$(m_ZipName, f, 1) = Chr$(97 + Fix(Rnd * 26))
        Next: m_ZipName = m_OutDir & k & m_ZipName & ".zip": GoTo NewZip
    ElseIf CreateFolder(FSO.GetParentFolderName(m_ZipName)) Then
NewZip:
        If Not FSO.FileExists(m_ZipName) Then
            FSO.CreateTextFile(m_ZipName, True).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
            LogStream.WriteLine Now & "[CreateZip]" & FSO.GetAbsolutePathName(m_ZipName)
        End If
    End If
 
    Set Zip = ShellApp.NameSpace(FSO.GetAbsolutePathName(m_ZipName))
    For f = 0 To UBound(Paths)
        Paths(f) = FSO.GetAbsolutePathName(Paths(f))
        If FSO.FileExists(Paths(f)) Or FSO.FolderExists(Paths(f)) Then Else GoTo Next_F
        If GetAttr(Paths(f)) And vbDirectory Then _
        If ShellApp.NameSpace((Paths(f))).Items.Count = 0 Then GoTo Next_F 'Пропускать пустые папки
        'Сравнение старых и новых потоков
        oldThreads = GetThreadsList: Zip.CopyHere ((Paths(f))): newThreads = GetThreadsList
        If UBound(newThreads) > UBound(oldThreads) Then
            hTrd = OpenThread(SYNCHRONIZE, False, newThreads(UBound(newThreads)))
            WaitForSingleObject hTrd, -1 'Ждать завершения операции сжатия
            CloseHandle hTrd
        End If
        ToZip = ToZip + 1
Next_F:
    Next
End Function
 
Public Function Make(Files()) As Long
    'Автокомпиляция проекта
    'Files = Список компилируемых файлов
    Dim FileName$, mDir$, ShellNum&, hProc&, f&
    LogStream.WriteLine Now & "[Make]"
    If Not CreateFolder(m_OutDir) Then LogStream.WriteLine Now & "[Error]" & m_OutDir: Exit Function
    mDir = """" & m_OutDir & """"
    For f = 0 To UBound(Files)
        Files(f) = FSO.GetAbsolutePathName(Files(f))
        If Not FSO.FileExists(Files(f)) Then GoTo Next_F
        Select Case LCase(FSO.GetExtensionName(Files(f)))
        Case "vbp", "vbg": Case Else: GoTo Next_F
        End Select: FileName = """" & Files(f) & """"
        ShellNum = Shell(FileVB6_EXE & " /Make " & FileName & " /OutDir " & mDir)
        hProc = OpenProcess(SYNCHRONIZE, False, ShellNum)
        Call WaitForSingleObject(hProc, -1)
        CloseHandle hProc
        Make = Make + 1
Next_F:
    Next
    
End Function
 
Private Sub Class_Initialize()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set LogStream = FSO.CreateTextFile(App.Path & "\LogStream.txt", 1)
    LogStream.WriteLine Now & "[Start]" 'Начало ведение лога
    Set ShellApp = CreateObject("Shell.Application")
    FileVB6_EXE = """" & Environ("ProgramFiles") & "\Microsoft Visual Studio\VB98\VB6.EXE" & """"
    OldDir = CurDir$: m_OutDir = OldDir: m_InitDir = OldDir
End Sub
 
Private Sub Class_Terminate()
    ChDir OldDir
    LogStream.Close 'Закрытие потока записи лога
End Sub