download.ctl

guan yu pai ke xi tong de ruan jian

                    If lpdestination2 <= " " Then
                        MsgBox "你没有输入文件名!", vbExclamation + vbOKOnly, "错误!"
                        GoTo 404
                    End If
                    If lpdestination = lpdestination2 Then
                        strreturn = MsgBox("同名文件已经存在,现有文件将被覆盖! 是否重新修改文件名?", vbCritical + vbYesNo, "错误...")
                            If strreturn = vbYes Then
                                GoTo 404
                            End If
                    End If
            End If
        End If
    Else
        If Len(Dir(lpdestination)) > 0 Then
            Kill lpdestination
        End If
    End If

    Open lpdestination For Binary Access Write As #intfile
    RaiseEvent StatusChange("DownLoad->>" & Right(lpdestination, Len(lpdestination) - InStrRev(lpdestination, "\")))
    m_InDL = True
    Do
        If c_Cancel = True Then
            c_Cancel = False
            m_InDL = False
            Close #intfile
            RaiseEvent DLError(4, "canceled!")
            Exit Sub
        End If
        bData = I1.GetChunk(CHUNK, icByteArray)
        Put #intfile, , bData
        If m_FileSize <= 0 Then
            c_Cancel = False
            m_InDL = False
            Close #intfile
            RaiseEvent DLComplete '触发DLComplete事件，表示下载结束。
            Exit Sub
        End If
        lBR = lBR + UBound(bData, 1) + 1
        m_BYTES = lBR
        r_RateTransfer = lBR / (Timer - t_OldTime)
        t_Time = (m_FileSize - lBR) / r_RateTransfer
        RaiseEvent Rate(FormatFileSize(r_RateTransfer))
        RaiseEvent TimeLeft(FormatTime(t_Time))
        RaiseEvent RecievedBytes(lBR)
        RaiseEvent Percent(Round((lBR / m_FileSize) * 100, 0))
        If c_Pause = True Then
            While c_Pause = True
                DoEvents
                RaiseEvent StatusChange("Pausse.")
            Wend
        End If
        DoEvents
    Loop While UBound(bData, 1) > 0
    Close #intfile
    m_InDL = False
    RaiseEvent DLComplete '触发DLComplete事件，表示下载结束。
    I1.Cancel
    Exit Sub
DLE:
    RaiseEvent DLError(1, "Unknown error!")
    I1.Cancel
    Exit Sub
End Sub

Sub GetFileInformation()
On Error GoTo Ge
    Dim sHeader As String
    Dim blnreturn As Boolean

    If c_Cancel = True Then
        c_Cancel = False
    End If

    If m_OnlineCheck = True Then '如果要求连网。
        blnreturn = IsOnline
        If blnreturn = False Then
            m_Connected = False
            RaiseEvent DLError(5, "No Connection To Internet.")
            Exit Sub
        Else
            m_Connected = True
        End If
    End If
    I1.Url = m_URL
    I1.Execute , "GET"
    While I1.StillExecuting
        DoEvents
    Wend
    If c_Cancel = True Then GoTo Cc

    sHeader = I1.GetHeader() '获取文件头信息。
    Select Case Mid$(sHeader, 10, 3)
        Case 401
            RaiseEvent DLError(401, "Unauthorized Access!")
            a_Resume = False
            I1.Cancel
            m_FileExists = True
            m_FileSize = 0
            Exit Sub
        Case 403
            RaiseEvent DLError(403, "Access Denied!")
            a_Resume = False
            m_FileExists = True
            m_FileSize = 0
            I1.Cancel
            Exit Sub
        Case 404
            RaiseEvent DLError(404, "File Not Find->>" & m_URL)
            m_FileExists = False
            m_FileSize = 0
            I1.Cancel
            Exit Sub
    End Select

    If c_Cancel = True Then GoTo Cc

    If Mid$(aheader, 6, 3) = "1.1" Then a_Resume = True
    
    m_FileExists = True
    t_OldTime = Timer - 1
    m_FileSize = CLng(I1.GetHeader("Content-Length"))
    m_LastModified = I1.GetHeader("Last-Modified") '取文件最后修改时间。
    Exit Sub

Ge:
    RaiseEvent DLError(3, "Server timed out!")
    Exit Sub

Cc:
    c_Cancel = False
    RaiseEvent DLError(4, "canceled.")
    Exit Sub
End Sub

Sub Cancel()
    '置取消状态。
    c_Cancel = True
    c_Pause = False
    m_InDL = False
End Sub
Sub Pause(blnPause As Boolean)
    If m_InDL = False Then Exit Sub '只有在接收状态下才可以暂停。
    '暂停/继续。
    c_Pause = blnPause '根据传入的参数决定暂停状态。
End Sub
Private Function FormatTime(ByVal sglTime As Single) As String
    '格式化时间。
    Select Case sglTime
        Case 0 To 59
            FormatTime = Format(sglTime, "0") & " sec"
        Case 60 To 3599
            FormatTime = Format(Int(sglTime / 60), "#0") & " min " & Format(sglTime Mod 60, "0") & " sec"
        Case Else
            FormatTime = Format(Int(sglTime / 3600), "#0") & " hr " & Format(sglTime / 60 Mod 60, "0") & " min"
    End Select
End Function

Private Function FormatFileSize(ByVal dFileSize As Double) As String
    '格式化文件大小。
    Select Case dFileSize
        Case 0 To 1023
            FormatFileSize = Round(dFileSize, 0) & " Bytes/S"
        Case 1024 To 1048575
            FormatFileSize = Round(dFileSize / 1024, 2) & " KB/S"
    End Select
End Function

Private Function KeepSave(lpURL As String, lpSL As String) As String
    '处理文件扩展名。
    Dim temphold(1 To 2) As String
    Dim lplace(1 To 2) As Long
    lplace(1) = InStr(Len(lpURL) - 5, lpURL, ".", vbTextCompare)
    temphold(1) = Right$(lpURL, Len(lpURL) - lplace(1))
    lplace(2) = InStr(Len(lpSL) - 5, lpSL, ".", vbTextCompare)
    temphold(2) = Left$(lpSL, lplace(2))
    KeepSave = temphold(2) & temphold(1)
End Function

Private Function IsOnline() As Boolean
    '判断网络是否连通，以及连接方式。
    Dim lflag As Long
    Dim blnreturn As Boolean
    blnreturn = InternetGetConnectedState(lflag, 0)
    If lflag And INTERNET_CONNECTION_MODEM Then
        RaiseEvent ConnectionState("MODEM")
    End If
    If lflag And INTERNET_CONNECTION_LAN Then
        RaiseEvent ConnectionState("LAN")
    End If
    If lflag And INTERNET_CONNECTION_PROXY Then
        RaiseEvent ConnectionState("PROXY")
    End If
    IsOnline = blnreturn
End Function
Function CreatFolder(ByVal hPath As String) As Boolean
    Dim fso As New FileSystemObject
    Dim PathItem() As String
    Dim DriverName As String
    Dim DispIndex As Long
    If Mid(hPath, 2, 2) <> ":\" Then
        RaiseEvent DLError(6, "Folder Name is Err.")
        CreatFolder = True
        Exit Function
    Else
        DriverName = Left(hPath, 2)
    End If
    hPath = Right(hPath, Len(hPath) - 3)
    DispIndex = InStrRev(hPath, "\")
    If DispIndex <> Len(hPath) Then
        If InStr(hPath, ".") > 0 Then
            hPath = Left(hPath, DispIndex - 1)
        End If
    Else
        hPath = Left(hPath, Len(hPath) - 1)
    End If
    PathItem = Split(hPath, "\")
    For DispIndex = 0 To UBound(PathItem)
        DriverName = DriverName & "\" & PathItem(DispIndex)
        If fso.FolderExists(DriverName) = False Then
            fso.CreateFolder DriverName
            If fso.FolderExists(DriverName) = False Then
                RaiseEvent DLError(7, "Folder is not creat.")
            End If
        End If
    Next
End Function

Function RegSaveString(Optional ByVal InDate As String = "", Optional ByVal hkey As Long = HKEY_CURRENT_USER, Optional ByVal strPath As String = LOGON_REG_VER, Optional ByVal strValue As String = "Ver") As Long
    Dim llKeyID As Long '打开键的ID
    Dim glStatus As Long
    '首先打开主键
    glStatus = RegOpenKey(hkey, strPath, llKeyID)
    If glStatus = 0& Then '成功则设置值
        If Len(InDate) = 0 Then '设为空值
            glStatus = RegSetValueEx(llKeyID, strValue, 0&, 1, 0&, 0&)
        Else '设为正常值
            glStatus = RegSetValueEx(llKeyID, strValue, 0&, 1, ByVal InDate, Len(InDate) + 1)
        End If
        glStatus = RegCloseKey(llKeyID)
    End If
    RegSaveString = glStatus
End Function
Function RegGetString(Optional ByVal hkey As Long = HKEY_CURRENT_USER, Optional ByVal strPath As String = LOGON_REG_VER, Optional ByVal strValue As String = "Ver") As String
    Dim llKeyID As Long '打开键的ID
    Dim llBufferSize As Long '需读取串的串值长度
    Dim lsKeyValue As String '存放读取的串值
    Dim glStatus As Long
    '预先置为空
    RegGetString = Empty
    '首先打开主键
    glStatus = RegOpenKey(hkey, strPath, llKeyID)
    If glStatus = 0& Then '成功则取需读取字串的串值大小
        glStatus = RegQueryValueEx(llKeyID, strValue, 0&, 1, 0&, llBufferSize)
        If llBufferSize < 2 Then '空值
            glStatus = RegCloseKey(llKeyID)
        Else '有值，正式读取串值
            lsKeyValue = String(llBufferSize + 1, " ")
            glStatus = RegQueryValueEx(llKeyID, strValue, 0&, 1, ByVal lsKeyValue, llBufferSize)
            If glStatus = 0& Then
                RegGetString = Left$(lsKeyValue, llBufferSize - 1)
            End If
            glStatus = RegCloseKey(llKeyID)
        End If
    End If
End Function