ydownload.ctl

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

        ExitCode = True
    Else
        SockConnect(Index).Close
        SockData(Index).Close
        Close #FR(Index)
        FR(Index) = 0
    End If
End Sub
Private Sub CloseAllHttp(Optional Index As Integer = -1)
Dim i As Integer
Dim J As Integer
    If Index = -1 Then
        For i = Process - 1 To 0 Step -1
            HttpSock(i).Close
            Close #FR(i)
            FR(i) = 0
        Next i
        CanDown = False
        ExitCode = True
    Else
        HttpSock(Index).Close
        Close #FR(Index)
        FR(Index) = 0
    End If
End Sub
Private Sub delay(ii As Integer)
Dim startTimer As Single
    startTimer = Timer
    While Timer - startTimer < ii
        DoEvents
        Sleep 1
    Wend
End Sub
Private Function TimeOut_Check(Optional AA As Boolean = False) As Boolean
Dim startTime As Single
    startTime = Timer
    TimeOut_Check = False
    While Timer - startTime < TimeOut And Not AA And Not ExitCode
        If NoErr = True Then
            TimeOut_Check = True
            Exit Function
        End If
        DoEvents
        Sleep 1
    Wend
    If ExitCode = True Then
        SendOk = False
    End If
    If Timer - startTime > TimeOut Then
        RaiseEvent OnError("超时-")
        SendOk = False
    End If
End Function
Private Function NoVbNull(LongString As String) As String
    If InStr(LongString, vbNullChar) > 0 Then
        NoVbNull = Left(LongString, InStr(LongString, vbNullChar) - 1)
    Else
        NoVbNull = LongString
    End If
End Function
Private Function Loaded(Ctrls As Winsock, Index As Integer) As Boolean
On Error GoTo 123
    If Ctrls.Index = Index Then
        Loaded = True
        Exit Function
    End If
123:
    Loaded = False
End Function

Private Sub CheckLengths(Str1 As String)
Dim i As Integer
Dim startpos As Integer
Dim endpos As Integer
Dim Tmp As String
Dim tmp1 As String
Dim atmp() As String
    atmp = Split(Str1, vbCrLf)
    For i = 0 To UBound(atmp)
        If InStr(1, atmp(i), "Last-Modified") > 0 Then
            endpos = Len(atmp(i))
            tmp1 = Mid(atmp(i), endpos, 1)
            While Not IsNumeric(tmp1)
                endpos = endpos - 1
                tmp1 = Mid(atmp(i), endpos, 1)
            Wend
            startpos = Len("Last-Modified:")
            Last_Modified = Trim(Mid(atmp(i), startpos + 1, endpos - startpos))
            Exit For
        End If
    Next i
    
    startpos = InStr(1, Str1, "Content-Length: ")
    startpos = startpos + Len("Content -Length:")
    Tmp = Mid(Str1, startpos, 1)
    endpos = startpos
    While IsNumeric(Tmp)
        endpos = endpos + 1
        Tmp = Mid(Str1, endpos, 1)
    Wend
    Tmp = Mid(Str1, startpos, endpos - startpos)
    
    startpos = InStr(1, Str1, "Content-Length: ")
    startpos = startpos + Len("Content -Length:")
    Tmp = Mid(Str1, startpos, 1)
    endpos = startpos
    While IsNumeric(Tmp)
        endpos = endpos + 1
        Tmp = Mid(Str1, endpos, 1)
    Wend
    Tmp = Mid(Str1, startpos, endpos - startpos)
    atmp = Split(Str1, vbCrLf)
    
    For i = 0 To UBound(atmp)
        If InStr(1, atmp(i), "Content-Range: bytes") > 0 Then
            endpos = Len(atmp(i))
            startpos = endpos
            tmp1 = Mid(atmp(i), endpos, 1)
            While tmp1 <> "/"
                startpos = startpos - 1
                tmp1 = Mid(atmp(i), startpos, 1)
            Wend
            tmp1 = Mid(atmp(i), startpos + 1, endpos - startpos)
            Exit For
        End If
    Next i
    If IsNumeric(Tmp) Then
        If IsNumeric(tmp1) Then
            If CLng(tmp1) > CLng(Tmp) Then
                FileLengths = CLng(tmp1)
                ProgressBar.Max = FileLengths
                WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
            Else
                FileLengths = CLng(Tmp)
                ProgressBar.Max = FileLengths
                WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
            End If
        Else
            FileLengths = CLng(Tmp)
            ProgressBar.Max = FileLengths
            WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
        End If
    End If
    
End Sub
Private Function CheckGet(Str1 As String) As Boolean
Dim i As Integer
Dim atmp() As String
    CheckGet = False
    atmp = Split(Str1, vbCrLf)
    For i = 0 To UBound(atmp)
        If InStr(1, atmp(i), "HTTP/") > 0 Then
            If InStr(1, atmp(i), "20") > 0 Then
                CheckGet = True
                Exit For
            End If
        End If
    Next i
End Function

Private Function GetfileLong(S As String) As Long
Dim Tmp As String
Dim atmp() As String
    GetfileLong = 0
    Tmp = Replace(S, "  ", " ")
    While Tmp <> S
        S = Tmp
        Tmp = Replace(S, "  ", " ")
        Sleep 1
    Wend
    atmp = Split(Tmp, " ")
    If UBound(atmp) > 4 Then
        If IsNumeric(atmp(4)) Then
            GetfileLong = CLng(atmp(4))
        Else
            GetfileLong = -1
        End If
    Else
        GetfileLong = -1
    End If
End Function

Private Function SendUser(Optional Index As Integer = 0) As Boolean
Dim U As String
    NoErr = False
    SendOk = False
    If UserName = "" Then
        U = "anonymous"
    Else
        U = UserName
    End If
    TmpConnect(Index) = "发送用户名"
    RaiseEvent OnMessageSend("USER " & U & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "USER " & U & vbCrLf
    TimeOut_Check
    SendUser = SendOk
End Function
Private Function HideString(Look As String, Hide As String) As String
Dim i As Integer
Dim Tmp As String
    Tmp = ""
    For i = 1 To Len(Look)
        Tmp = Tmp & Hide
    Next i
    HideString = Tmp
End Function
Private Function SendPass(Optional Index As Integer) As Boolean
Dim P As String
    NoErr = False
    SendOk = False
    If PassWord = "" Then
        P = "[e-mail]"
    Else
        P = PassWord
    End If
    TmpConnect(Index) = "发送密码"
    RaiseEvent OnMessageSend("PASS " & HideString(P, "*") & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "PASS " & P & vbCrLf
    TimeOut_Check
    SendPass = SendOk
End Function
Private Function SendTYPEI(Optional Index As Integer = 0) As Boolean  '二进制下载
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "二进制下载"
    RaiseEvent OnMessageSend("TYPE I" & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "TYPE I" & vbCrLf
    TimeOut_Check
    SendTYPEI = SendOk
End Function
Private Function SendTYPEA(Optional Index As Integer = 0) As Boolean    'ASCII码下载
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "ASCII码下载"
    RaiseEvent OnMessageSend("TYPE A" & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "TYPE A" & vbCrLf
    TimeOut_Check
    SendTYPEA = SendOk
End Function
Private Function SendSIZE(Optional Index As Integer = 0) As Boolean
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "获取文件大小"
    RaiseEvent OnMessageSend("SIZE " & ServerPath & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "SIZE " & ServerPath & vbCrLf
    TimeOut_Check
    SendSIZE = SendOk
End Function
Private Function SendPASV(Optional Index As Integer = 0) As Boolean   '被动下载
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "被动下载"
    RaiseEvent OnMessageSend("PASV" & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "PASV" & vbCrLf
    TimeOut_Check
    SendPASV = SendOk
End Function
Private Function SendRETR(Posi As Long, Optional Index As Integer = 0) As Boolean
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "开始下载"
    DownNoBeg(Index) = True
    Close #FR(Index)
    FR(Index) = FreeFile
    Open LocalPath For Binary Access Write As #FR(Index)
    RaiseEvent OnMessageSend("RETR " & ServerPath & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "RETR " & ServerPath & vbCrLf
    TimeOut_Check
    SendRETR = SendOk
End Function

Private Function SendREST(Posi As Long, Optional Index As Integer = 0) As Boolean
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "下载点"
    RaiseEvent OnMessageSend("REST " & Posi & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "REST " & Posi & vbCrLf
    TimeOut_Check
    SendREST = SendOk
End Function

Private Function SendList(Optional Index As Integer = 0) As Boolean
    NoErr = False
    SendOk = False
    TmpConnect(Index) = "列表"
    RaiseEvent OnMessageSend("LIST " & ServerPath & vbCrLf)
    If SockConnect(Index).State = 7 Then SockConnect(Index).SendData "LIST " & ServerPath & vbCrLf
    TimeOut_Check
    SendList = SendOk
End Function
Private Sub ConnectData(Port As Long, Optional Index As Integer = 0)
    DownNoBeg(Index) = False
    NoErr = False
    SendOk = False
    SockData(Index).Close
    SockData(Index).RemoteHost = ServerName
    SockData(Index).RemotePort = Port
    SockData(Index).Connect
End Sub
Private Sub SockConnect_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    NoErr = True
    SendOk = False
    Me.LinkClose
End Sub



Private Sub SockData_Connect(Index As Integer)
    NoErr = True
    SendOk = True
End Sub

Private Sub SockData_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim AA As String
Dim szData() As Byte
Dim TmpSize As Long
On Error GoTo 123
    If ExitCode = True Or Closeed Then
        Exit Sub
    End If
    If DownNoBeg(Index) = True Then
        SockData(Index).GetData szData, vbArray + vbByte
        If FR(Index) <> 0 Then
            Seek #FR(Index), Position(Index) + AlreadyDown(Index) + 1
            Put #FR(Index), , szData
'        DownSize(Index) = DownSize(Index) + bytesTotal
            AlreadyDown(Index) = AlreadyDown(Index) + bytesTotal
        End If
        If AlreadyDown(Index) >= EndPosition(Index) - Position(Index) Then
            AlreadyDown(Index) = EndPosition(Index) - Position(Index)
            CloseAll Index
        End If
        Select Case Index
        Case 0
            Already1 = AlreadyDown(Index)
        Case 1
            Already2 = AlreadyDown(Index)
        Case 2
            Already3 = AlreadyDown(Index)
        Case 3
            Already4 = AlreadyDown(Index)
        Case 4
            Already5 = AlreadyDown(Index)
    End Select
        TmpSize = 0
        For i = 0 To Process - 1
            TmpSize = AlreadyDown(i) + TmpSize
        Next i
        DownLen = TmpSize
        If DownLen <= ProgressBar.Max Then ProgressBar.Value = DownLen
        RaiseEvent OnGetData(DownLen)
        If TmpSize >= FileLengths And FileLengths > 0 Then
            'Kill PathName
            DownLen = FileLengths
            DownloadisOk = True
            RaiseEvent OnCompleted
            DownloadisOk = True
            Me.LinkClose
        End If
    Else
        If SockData(Index).State = 7 Then SockData(Index).GetData AA
        RaiseEvent OnMessageReceive(AA)
        FileLengths = GetfileLong(Trim(AA))
        'WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
        NoErr = True
    End If
    Exit Sub
123:
    RaiseEvent OnError(Err.Description)
    Me.LinkClose
End Sub

Private Sub SockData_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    CloseAll Index
    NoErr = True
    SendOk = False
    RaiseEvent OnError(Description)
    Me.LinkClose
End Sub



Public Sub LinkClose()
Dim i As Integer
    If Closeed Then Exit Sub
    ExitCode = True
    FirstProcess = True
    Closeed = True
    SendOk = False
    DownAgain.Enabled = False
    BeginTime.Enabled = False
    If CanDown And PathName <> "" Then
        For i = 0 To Process - 1
            WritePrivateProfileString LCase(URL & LocalPath), "P" & CStr(i), CStr(AlreadyDown(i)), PathName
        Next i
    End If
    CloseAll
    CloseAllHttp
    If DownloadisOk = True Then
        RaiseEvent OnBegin("完成")
        WritePrivateProfileString LCase(URL & LocalPath), "DOWNSTATE", "完成", PathName
    Else
        RaiseEvent OnBegin("等待")
    End If
    State = "等待"
    RaiseEvent OnEnd(DownloadisOk)
    CanDownLoad = False
End Sub


Private Sub UserControl_Resize()
On Error Resume Next
    ProgressBar.Left = 0
    ProgressBar.Top = 0
    ProgressBar.Width = UserControl.ScaleWidth
    ProgressBar.Height = UserControl.Height
Err.Clear
End Sub

Private Sub UserControl_Terminate()
Dim i As Integer
    For i = 0 To Process - 1
        If AlreadyDown(i) > 0 And PathName <> "" Then WritePrivateProfileString LCase(URL & LocalPath), "P" & CStr(i), CStr(AlreadyDown(i)), PathName
    Next i
End Sub