ydownload.ctl

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

            RaiseEvent OnCompleted
            Me.LinkClose
            Exit Sub
        End If
    End If
    If TmpSize <> CheckSize Then
        CheckSize = TmpSize
        startTime = Timer
    Else
        If startTimer = 0 Then startTimer = Timer
        If Timer - startTime > TimeOut Then
            ExitCode = True
            RaiseEvent OnError("超时_")
            Me.LinkClose
            startTimer = 0
        End If
    End If
End Sub

Private Sub HttpSock_Close(Index As Integer)
If Not CheckInfo Then
    If Not ExitCode And CanDown Then
        delay 5
        If AlreadyDown(Index) < EndPosition(Index) - Position(Index) Then HttpSend Index, True
    Else
        NoErr = True
        Me.LinkClose
    End If
End If
End Sub

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

Private Sub HttpSock_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim szData() As Byte
Dim rData() As Byte
Dim TmpStr1 As String
Dim i As Integer
'On Error GoTo 123
    If ExitCode = True Or Closeed Then
        Exit Sub
    End If
    If HttpSock(Index).State = 7 Then
        HttpSock(Index).GetData szData, vbArray + bytesTotal
    Else
        Exit Sub
    End If
    If Not DownNoBeg(Index) Then
        If bytesTotal > 0 Then
            ReDim rData(bytesTotal - InStr(StrConv(szData, vbUnicode), vbCrLf & vbCrLf) - 3)
            rData = RightB(szData, UBound(rData))
            TmpStr1 = Left(StrConv(szData, vbUnicode), InStr(StrConv(szData, vbUnicode), vbCrLf & vbCrLf) + 3)
            RaiseEvent OnMessageReceive(TmpStr1)
            If InStr(1, TmpStr1, "HTTP/") > 0 Then
                NoErr = True
                If CheckGet(TmpStr1) Then
                    If Not CheckInfo Then
                        SendOk = True
                        If CanDown = False Then
                            CheckLengths TmpStr1
                            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
                            CanDown = True
                        End If
                        If FR(Index) <> 0 Then
                            Seek #FR(Index), Position(Index) + AlreadyDown(Index) + 1
                            Put #FR(Index), , rData
                            AlreadyDown(Index) = AlreadyDown(Index) + UBound(rData) + 1
                        End If
                        DownNoBeg(Index) = True
                    Else
                        CheckLengths TmpStr1
                        Me.LinkClose
                        Exit Sub
                    End If
                Else
                    SendOk = False
                    Exit Sub
                End If
            Else
                SendOk = False
            End If
        End If
    Else
        If FR(Index) <> 0 Then
            Seek #FR(Index), Position(Index) + AlreadyDown(Index) + 1
            Put #FR(Index), , szData
            AlreadyDown(Index) = AlreadyDown(Index) + bytesTotal
        End If
'        DownSize(Index) = DownSize(Index) + bytesTotal
    End If
    If AlreadyDown(Index) >= EndPosition(Index) - Position(Index) Then
        AlreadyDown(Index) = EndPosition(Index) - Position(Index)
        CloseAllHttp 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
        DownloadisOk = True
        RaiseEvent OnCompleted
        DownloadisOk = True
        Me.LinkClose
    End If
    Exit Sub
123:
    RaiseEvent OnError(Err.Description)
    Me.LinkClose
End Sub

Private Sub HttpSock_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
    RaiseEvent OnError(Description)
    Me.LinkClose
End Sub


Private Sub SockConnect_DataArrival(Index As Integer, ByVal bytesTotal As Long)
Dim AA As String
Dim TmpSize As Long
Dim i As Integer
Dim atmp() As String
Dim Btmp() As String
Dim Ctmp() As String
On Error GoTo 123
    If SockConnect(Index).State = 7 Then
        SockConnect(Index).GetData AA
    Else
        Exit Sub                                                      '注意此处可能发生错误
    End If
    RaiseEvent OnMessageReceive(AA)
    If TmpConnect(Index) = "连接服务器" Then
        If InStr(AA, "220") > 0 Then
            atmp = Split(AA, "220")
            If Left(atmp(UBound(atmp)), 1) <> "-" Then
                NoErr = True
                SendOk = True
            End If
        Else
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "发送用户名" Then
        If InStr(AA, "331") > 0 Then
            NoErr = True
            SendOk = True
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":发送用户名出错")
            Else
                RaiseEvent OnError("发送用户名出错")
            End If
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "发送密码" Then
        If InStr(AA, "230") > 0 Then
            NoErr = True
            SendOk = True
        End If
        If InStr(AA, "530") > 0 Then
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":密码出错")
            Else
                RaiseEvent OnError("密码出错")
            End If
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "获取文件大小" Then
        If InStr(AA, "213") > 0 Then
            atmp = Split(AA, vbCrLf)
            Btmp = Split(atmp(0), " ")
            If IsNumeric(Btmp(1)) Then
                FileLengths = CLng(Btmp(1))
                ProgressBar.Max = FileLengths
                WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
            End If
            NoErr = True
            SendOk = True
        Else
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "被动下载" Then
        If InStr(AA, "227") > 0 Then
            atmp = Split(AA, vbCrLf)
            Btmp = Split(atmp(UBound(atmp) - 1), "(")
            Ctmp = Split(Left(Btmp(1), Len(Btmp(1)) - 1), ",")
            DataPort = CLng(Ctmp(UBound(Ctmp) - 1)) * 256 + CLng(Ctmp(UBound(Ctmp)))
            NoErr = True
            SendOk = True
            'ConnectData DataPort
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法打开被动模式")
            Else
                RaiseEvent OnError("无法打开被动模式")
            End If
            NoErr = True
            SendOk = False
        End If
        NoErr = True
    End If
    If TmpConnect(Index) = "二进制下载" Then
        If InStr(AA, "200") > 0 Then
            NoErr = True
            SendOk = True
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法打开二进制下载")
            Else
                RaiseEvent OnError("无法打开二进制下载")
            End If
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "ASCII码下载" Then
        If InStr(AA, "200") > 0 Then
            NoErr = True
            SendOk = True
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法打开ASCII码下载")
            Else
                RaiseEvent OnError("无法打开ASCII码下载")
            End If
            NoErr = True
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "下载点" Then
        If InStr(AA, "350") > 0 Then
            NoErr = True
            SendOk = True
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":设置断点出错")
            Else
                RaiseEvent OnError("设置断点出错")
            End If
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "开始下载" Then
        If InStr(AA, "150") > 0 Then  'Or InStr(AA, "226")
            atmp = Split(AA, "(")
            If UBound(atmp) >= 1 Then
                Btmp = Split(atmp(1))
                If IsNumeric(Btmp(0)) Then
                    If FileLengths <= 0 Then
                        FileLengths = CLng(Btmp(0))
                        ProgressBar.Max = FileLengths
                        WritePrivateProfileString LCase(URL & LocalPath), "FILELENG", CStr(FileLengths), PathName
                        If FileLengths > 0 Then EndPosition(0) = FileLengths / Process
                    End If
                End If
            End If
            NoErr = True
            SendOk = True
        Else
            NoErr = True
            If InStr(AA, "550") > 0 Then
                If CanDown Then
                    RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法RETR下载")
                Else
                    RaiseEvent OnError("无法RETR下载")
                End If
            Else
                If CanDown Then
                    RaiseEvent OnError("线程" & CStr(Index + 1) & ":下载出错")
                Else
                    RaiseEvent OnError("下载出错")
                End If
            End If
            
            SendOk = False
        End If
    End If
    If TmpConnect(Index) = "列表" Then
        If InStr(AA, "150") > 0 Or InStr(AA, "226") > 0 Then
            NoErr = True
            SendOk = True
        Else
            If CanDown Then
                RaiseEvent OnError("线程" & CStr(Index + 1) & ":无法打开LIST列表")
            Else
                RaiseEvent OnError("无法打开LIST列表")
            End If
            NoErr = True
            SendOk = False
        End If
    End If

    If TmpConnect(Index) = "下载中" Then
        If InStr(AA, "550") > 0 Then
            RaiseEvent OnError("线程" & CStr(Index + 1) & ":下载时出错:等待5秒")
            Me.LinkClose
        End If
        If InStr(AA, "226") > 0 Then
            delay 2
            If Process > 1 Then
                AlreadyDown(Process - 1) = EndPosition(Process - 1) - Position(Process - 1)
            Else
                AlreadyDown(0) = FileLengths
            End If
        End If
    End If
    Exit Sub
123:
    If CanDown = False Then
        RaiseEvent OnError(Err.Description)
        Me.LinkClose
    End If
End Sub
Private Function CreatePath(Path As String) As Boolean
Dim Str1 As String
Dim i As Integer
Dim J As Integer
Dim myfs As Object
Dim atmp(100)
On Error GoTo ERRR:
    CreatePath = False
    Set myfs = CreateObject("Scripting.FileSystemObject")
    Str1 = myfs.GetParentFolderName(Path)
    i = 0
    atmp(i) = Path
    i = i + 1
    atmp(i) = Str1
    While Str1 <> ""
        Str1 = myfs.GetParentFolderName(Str1)
        i = i + 1
        atmp(i) = Str1
        DoEvents
    Wend
    For J = i - 1 To 0 Step -1
        If Not myfs.FolderExists(atmp(J)) Then myfs.CreateFolder (atmp(J))
    Next J
    CreatePath = True
ERRR:
Err.Clear
End Function
Private Function GetServerName(ByVal szAddr As String) As Boolean
Dim startpos As Long, endpos As Long
    GetServerName = False
On Error GoTo 123
    startpos = InStr(szAddr, "//") + 2
    If startpos = 0 Then
        ServerName = ""
        Exit Function
    End If
    endpos = InStr(startpos, szAddr, "/")
    If endpos = 0 Then endpos = Len(szAddr) + 1
    ServerName = Mid(szAddr, startpos, endpos - startpos)
    GetServerName = True
123:
    Err.Clear
End Function

Private Function GetFileName(ByVal szAddr As String) As String
Dim startpos As Long, endpos As Long
    endpos = Len(szAddr)
    startpos = endpos
    While Mid(szAddr, startpos, 1) <> "/"
        startpos = startpos - 1
    Wend
    GetFileName = Mid(szAddr, startpos + 1, endpos - startpos)
    If GetFileName = "" Then GetFileName = "index.htm"
End Function
Private Function GetServerPath(ByVal szAddr As String) As Boolean
Dim startpos As Integer
    GetServerPath = False
    On Error GoTo 123:
    startpos = InStr(szAddr, "//") + 2
    startpos = InStr(startpos, szAddr, "/")
    If startpos = 0 Then
        ServerPath = "/"
        Exit Function
    End If
    ServerPath = Right(szAddr, Len(szAddr) - startpos + 1)
    GetServerPath = True
123:
    Err.Clear
End Function
Private Sub CloseAll(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
            SockConnect(i).Close
            SockData(i).Close
            Close #FR(i)
            FR(i) = 0
        Next i
        CanDown = False