vb6实现下载带进度

可以通过修改sleep的时间和每次下载的字节数来控制下载速度，窗体只有一个label1和一个command1

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim mDownLoaddComPlete As Boolean

Private Sub Command1_Click()
    Dim Filename As String
    Dim Url As String
    Dim fso
    Dim aso
    Dim http
    Dim current
    Dim start
    Dim i
    Dim total
    Dim temp As String
    Dim range As String
    Dim Dnbyte

    Dnbyte = 20480       '20K 每次下载的字节数n*1024
    Url = "http://111.230.45.209:5500/doorlocktype/btlock57L_1027K.rar"
    Filename = "E:\下载\btlock57L_1027K.rar"

    If Not Left(Url, 7) = "http://" Then
        Url = "http://" & Url
    End If

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set aso = CreateObject("ADODB.Stream")
    Set http = CreateObject("Microsoft.XMLHTTP")

    If Dir(Filename) <> "" Then
        Kill Filename
    End If

    fso.CreateTextFile(Filename).Close
    aso.Type = 1 '数据流类型设为字节'
    aso.open
    aso.loadfromfile Filename '打开文件'
    start = 0
    current = 0
    Label1 = "开始下载：" & Filename
    Do
        http.open "GET", Url, True
        http.setrequestheader "Range", "bytes=" & start & "-" & CStr(start + Dnbyte)
        http.setrequestheader "Content-Type:", "application/octet-stream"
        http.send '构造完数据包就开始发送'
    
        For i = 1 To 120 '循环等待'
            If http.ReadyState = 4 Then Exit For '状态4表示数据接受完成'
            Sleep 10 '等待10ms'
            DoEvents
        Next
    
        If http.Status = 416 Then
            mDownLoaddComPlete = True
            Exit Do '下载完成
        End If
    
        If http.Status = 403 Then
            MsgBox "连接数过多", vbInformation, "提示"
            Exit Do
        End If
    
        If http.Status = 404 Then
            MsgBox "文件无法找到", vbInformation, "提示"
            Exit Do
        End If
    
        If Not http.ReadyState = 4 Then
            MsgBox "下载文件超时", vbInformation, "提示"
            Exit Do
        End If
    
        If http.Status > 299 Then
            MsgBox Url & "未知错误：" & http.StatusText & "(" & http.Status & ")", vbInformation, "提示"
            Exit Do
        End If
    
        If Not http.Status = 206 Then
            MsgBox "不支持断点续传", vbInformation, "提示"
            Exit Do
        End If
    
        aso.position = start '设置文件指针初始位置'
        aso.Write http.responsebody '写入数据'
        range = http.getresponseheader("Content-Range")                      '获得http头中的"Content-Range"'
    
        If range = "" Then
            MsgBox "无法获取文件大小！", vbInformation, "提示" '没有它就不知道下载完了没有'
        End If
    
        temp = Mid(range, InStr(range, "-") + 1)                           'Content-Range是类似123-456/789的样子'
        current = CLng(Left(temp, InStr(temp, "/") - 1))                  '123是开始位置，456是结束位置'
        total = CLng(Mid(temp, InStr(temp, "/") + 1))                        '789是文件总字节数'
        Label1 = Int(current / total * 100) & "%(" & current & "/" & total & ")"
    
        If total - current = 1 Then
            mDownLoaddComPlete = True
            Exit Do '结束位置比总大小少1就表示传输完成了'
        End If
    
        start = start + Dnbyte        '继续下载
        DoEvents
    Loop While True
    
    aso.SaveToFile Filename, 2 '保存文件
    aso.Close
    Set aso = Nothing
    Set fso = Nothing
    
    If mDownLoaddComPlete = True Then
        Label1 = "下载完成！(共" & total & "字节)" '下载完了，显示总字节数'
    End If

End Sub