ydownload.ctl

可以看到ftp与http下载的源理

        Else
            AlreadyDown(i) = 0
        End If
    Next i
    Position(0) = 0
    If URL = "" Then
        RaiseEvent OnError("URL为空，请设置完整URL")
        Me.LinkClose
        Exit Sub
    Else
        If GetServerName(URL) = False Then
            RaiseEvent OnError("分析URL时出错")
            Me.LinkClose
            Exit Sub
        End If
        If GetServerPath(URL) = False Then
            RaiseEvent OnError("分析URL中路径时出错")
            Me.LinkClose
            Exit Sub
        End If
    End If
    If Left(LCase(URL), 4) = "http" Then
        TB = HttpDownFirst
        If TB Then
            State = "下载中"
            RaiseEvent OnBegin("下载中")
            BeginTime.Enabled = True
            FirstProcess = True
        Else
            Me.LinkClose
            Exit Sub
        End If
    Else
        If Left(LCase(URL), 3) = "ftp" Then
            TB = FtpDownFirst
            If TB Then
                State = "下载中"
                RaiseEvent OnBegin("下载中")
                BeginTime.Enabled = True
                FirstProcess = True
            Else
                Me.LinkClose
                Exit Sub
            End If
        Else
            RaiseEvent OnError("无http或ftp开头")
            Me.LinkClose
            Exit Sub
        End If
    End If
    DownAgain.Enabled = True
    Exit Sub
123:
    RaiseEvent OnError(Err.Description)
    Err.Clear
    Me.LinkClose
End Sub
Private Function HttpDownFirst() As Boolean
Dim WebString As String
    HttpDownFirst = False
    Close #FR(0)
    FR(0) = FreeFile
    Open LocalPath For Binary Access Write As #FR(0)
    HttpSock(0).Close
    HttpSock(0).RemoteHost = ServerName
    HttpSock(0).RemotePort = 80
    HttpSock(0).Connect
    TimeOut_Check
    If Not SendOk Then
        Me.LinkClose
        Exit Function
    End If
    WebString = "GET " & URL & " HTTP/1.0" & vbCrLf
    WebString = WebString & "Host: " & ServerName & vbCrLf
    WebString = WebString & "Accept: */*" & vbCrLf
    WebString = WebString & "Referer: http://" & ServerName & vbCrLf
    WebString = WebString & "User-Agent: Mozilla/4.0 (compatible; MSIE 5.00; Windows 98)" & vbCrLf
    If AlreadyDown(0) <> 0 Then
        WebString = WebString & "Range: bytes=" & CStr(AlreadyDown(0)) & "-" & vbCrLf
    End If
    WebString = WebString & "cache -Control: no -cache" & vbCrLf
    WebString = WebString & "Connection: Close" & vbCrLf & vbCrLf
    RaiseEvent OnMessageSend(WebString)
    SendOk = False
    NoErr = False
    DownNoBeg(0) = False
    If HttpSock(0).State = 7 Then
        HttpSock(0).SendData WebString
        TimeOut_Check
        If SendOk = False Then
            Me.LinkClose
            Exit Function
        End If
    Else
        Me.LinkClose
        Exit Function
    End If
    If FileLengths <= 0 Then
        RaiseEvent OnError("无法获得文件大小")
        Me.LinkClose
        Exit Function
    End If
    CanDown = True
    HttpDownFirst = True
    Exit Function
123:
    RaiseEvent OnError(Err.Description)
    NoErr = True
    SendOk = False
    HttpDownFirst = False
    Err.Clear
End Function
Private Function HTTPDOWN(Index As Integer) As Boolean
Dim i As Integer
On Error GoTo 1234:
    HTTPDOWN = False
    If ExitCode = True Then
        Exit Function
    End If
    NoErr = False
    SendOk = False
    If ExitCode = False Then
        Close #FR(Index)
        FR(Index) = FreeFile
        Open LocalPath For Binary Access Write As #FR(Index)
        If Not HttpSend(Index, True) Then
            CloseAllHttp Index
        Else
            HTTPDOWN = True
        End If
    End If
1234:
        If Err.Number <> 0 Then RaiseEvent OnError(Err.Description)
        Err.Clear
End Function

Private Function HttpSend(Index As Integer, First As Boolean) As Boolean
Dim WebString As String
On Error GoTo 123
    HttpSend = False
    NoErr = False
    SendOk = False
    HttpSock(Index).Close
    HttpSock(Index).RemoteHost = ServerName
    HttpSock(Index).RemotePort = 80
    HttpSock(Index).Connect
    TimeOut_Check
    HttpSend = SendOk
    If Not SendOk Then
        Exit Function
    End If
    WebString = "GET " & URL & " HTTP/1.0" & vbCrLf
    WebString = WebString & "Host: " & ServerName & vbCrLf
    WebString = WebString & "Accept: */*" & vbCrLf
    WebString = WebString & "Referer: http://" & ServerName & vbCrLf
    WebString = WebString & "User-Agent: Mozilla/4.0 (compatible; MSIE 5.00; Windows 98)" & vbCrLf
    If First = True Then
        If Index = 0 Then
            If AlreadyDown(0) <> 0 Then
                WebString = WebString & "Range: bytes=" & CStr(AlreadyDown(0)) & "-" & vbCrLf
            End If
        Else
            WebString = WebString & "Range: bytes=" & CStr(EndPosition(Index - 1) + AlreadyDown(Index)) & "-" & vbCrLf
        End If
    End If
    WebString = WebString & "cache -Control: no -cache" & vbCrLf
    WebString = WebString & "Connection: Close" & vbCrLf & vbCrLf
    RaiseEvent OnMessageSend(WebString)
    SendOk = False
    NoErr = False
    DownNoBeg(Index) = False
    If HttpSock(Index).State = 7 Then
        HttpSock(Index).SendData WebString
        TimeOut_Check
        HttpSend = SendOk
    End If
    Exit Function
123:
    RaiseEvent OnError(Err.Description)
    NoErr = True
    SendOk = False
    HttpSend = False
    Err.Clear
End Function
Private Function FtpDownFirst() As Boolean
Dim i As Integer
Dim kk As Integer
    FtpDownFirst = False
    NoErr = False
    SendOk = False
    TmpConnect(0) = "连接服务器"
    SockConnect(0).Close
    SockConnect(0).RemoteHost = ServerName
    SockConnect(0).RemotePort = 21
    SockConnect(0).Connect
    TimeOut_Check
    If SendOk = False Then
        Me.LinkClose
        Exit Function
    End If
    SendOk = False
    If Not SendUser Then
        Me.LinkClose
        Exit Function
    End If
    If Not SendPass Then
        Me.LinkClose
        Exit Function
    End If
    If Not SendTYPEI Then
        Me.LinkClose
        Exit Function
    End If
    If Not SendREST(100) Then
        Me.LinkClose
        Position(0) = 0
    End If
    If Not SendTYPEI Then
        Me.LinkClose
        Exit Function
    End If
    If Not SendSIZE Then
        If Not SendPASV Then
            Me.LinkClose
            Exit Function
        End If
        ConnectData DataPort
        TimeOut_Check SockData(0).State = 7
        If Not SendOk Then
            RaiseEvent OnError("无法打开数据传输端口")
            Me.LinkClose
            Exit Function
        End If
        FileLengths = 0
        SendList
        NoErr = False
        TimeOut_Check FileLengths <> 0
        If FileLengths <= 0 Then
            FileLengths = 0
            RaiseEvent OnError("无法获取文件大小")
            Me.LinkClose
            Exit Function
        End If
    End If
        
    If FileLengths > 2000000 Then
        EndPosition(0) = FileLengths \ Process
        For i = 1 To Process - 1
            Position(i) = EndPosition(i - 1)
            TmpPosition(i) = EndPosition(i - 1) + AlreadyDown(i)
            EndPosition(i) = FileLengths * (i + 1) \ Process
        Next i
    Else
        Process = 1
        If FileLengths > 0 Then EndPosition(0) = FileLengths / Process
    End If
    If TmpPosition(0) < EndPosition(0) Then
        FtpDownFirst = FtpSend(0, False)
    End If
'    If FtpDownFirst = False Then Exit Function
'    For i = 1 To Process - 1
'        If TmpPosition(i) < EndPosition(i) Then FTPDOWN i
'        DoEvents
'        Sleep 1
'    Next i
End Function
Private Function FTPDOWN(Index As Integer) As Boolean
Dim i As Integer
Dim kk As Integer
On Error GoTo 1234
    FTPDOWN = False
    NoErr = False
    SendOk = False
    If ExitCode = False Then
        FTPDOWN = FtpSend(Index, True)
    End If
1234
    If Err.Number <> 0 Then RaiseEvent OnError(Err.Description)
    Err.Clear
End Function

Private Function FtpSend(Index As Integer, First As Boolean, Optional lay As Boolean = False) As Boolean
Dim Tmp As Long
On Error GoTo 123
    If lay = True Then
        delay 5
    End If
    FtpSend = False
    If First = True Then
        NoErr = False
        SendOk = False
        TmpConnect(Index) = "连接服务器"
        SockConnect(Index).Close
        SockConnect(Index).RemoteHost = ServerName
        SockConnect(Index).RemotePort = 21
        SockConnect(Index).Connect
        TimeOut_Check
        If SendOk = False Then
            Exit Function
        End If
        If Not SendUser(Index) Then
            RaiseEvent OnError("线程" & CStr(Index + 1) & ":发送用户名出错" & vbCrLf)
            Exit Function
        End If
        If Not SendPass(Index) Then
            RaiseEvent OnError("线程" & CStr(Index + 1) & ":密码出错" & vbCrLf)
            Exit Function
        End If
    End If
    If Not SendTYPEI(Index) Then
        RaiseEvent OnError("线程" & CStr(Index + 1) & ":打开二进制时出错" & vbCrLf)
        Exit Function
    End If

    If Not SendPASV(Index) Then
        RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法被动模式下载" & vbCrLf)
        Exit Function
    End If
    ConnectData DataPort, Index
    TimeOut_Check
    If Not SendOk Then
        Exit Function
    End If
    If Index = 0 Then
        Tmp = AlreadyDown(Index)
    Else
        Tmp = EndPosition(Index - 1) + AlreadyDown(Index)
    End If
    If Not SendREST(Tmp, Index) Then
        Exit Function
    End If
    If SendRETR(Tmp, Index) Then
        TmpConnect(Index) = "下载中"
        FtpSend = True
    End If
    Exit Function
123:
    NoErr = True
    SendOk = False
    FtpSend = False
    RaiseEvent OnError(Err.Description)
    Err.Clear
End Function

Private Sub BeginTime_Timer()
Dim i As Integer
Dim K As Integer
Dim TmpSize As Long
    BeginTime.Enabled = False
    FirstProcess = True
    DoEvents
    TmpConnect(0) = "连接服务器"
    NoErr = False
    TmpSize = 0
    For i = 0 To Process - 1
        TmpSize = TmpSize + AlreadyDown(i)
    Next i
    If LCase(Left(URL, 4)) = "http" Then
        If TmpSize >= FileLengths And FileLengths > 0 Then
            delay 5
            DownLen = FileLengths
            DownloadisOk = True
            RaiseEvent OnGetData(DownLen)
            RaiseEvent OnCompleted
            Me.LinkClose
        Else
            For i = 1 To Process - 1
                If TmpPosition(i) < EndPosition(i) Then HTTPDOWN i
            Next i
        End If
    End If
    If LCase(Left(URL, 3)) = "ftp" Then
        If TmpSize >= FileLengths And FileLengths > 0 Then
            delay 5
            DownLen = FileLengths
            DownloadisOk = True
            RaiseEvent OnGetData(DownLen)
            RaiseEvent OnCompleted
            Me.LinkClose
        Else
            For i = 1 To Process - 1
                If TmpPosition(i) < EndPosition(i) Then FTPDOWN i
                DoEvents
                Sleep 1
            Next i
        End If
    End If
End Sub








Private Sub Command1_Click()
    Me.GetUrlInfo "http://www.st121.com.cn/sst/sst.out"
    MsgBox Last_Modified
End Sub

'Private Sub Command1_Click()
'    Command1.Enabled = False
'    PathName = "C:\listlog.txt"
'    URL = "http://www.st121.com.cn/t213_20.rar"
'    Me.Process = 5
'    Me.DownTo URL, "C:\"
'End Sub
'
'Private Sub Command2_Click()
'Me.LinkClose
'Command1.Enabled = True
'End Sub

Private Sub DownAgain_Timer()
Dim i As Integer
Dim TmpSize As Long
Static startTime As Single
Static CheckSize As Long
    TmpSize = 0
    For i = 0 To Process - 1
        TmpSize = TmpSize + AlreadyDown(i)
    Next i
    If TmpSize >= FileLengths And FileLengths > 0 Then
        delay 5
        ProgressBar.Value = FileLengths
        If ExitCode = False Then
            RaiseEvent OnGetData(FileLengths)
            DownloadisOk = True