使用XMLHTTP组件实现HTTP协议下的分块断点续传

    使用XMLHTTP下载基于HTTP协议传输的文件，如果文件较大，一般可以考虑使用异步方式，但VB里XMLHTTP异步仍然会造成线程阻塞，如何避免这种情况，本文章就此作了一个演示：

'* ************************************** * '* 模块名称：Form1.frm '* 模块功能：使用XMLHTTP组件实现HTTP协议下的断点续传 '* 作者：lyserver '* ************************************** * Dim m_blnStop As Boolean '* ------------------------------------------- ' 函数说明：基于XMLHTTP的数据下载函数（支持断点续传） ' 参数说明：URL待下载的URL ' FileName保存下载结果的文件 ' BlockSize分块大下，根据网络情况而定，以便VB能及时执行DoEvents来获得鼠标和键盘动作并刷新界面 ' ResumeTransfer是否支持断点续传 ' 编码：lyserver '* ------------------------------------------- Private Sub DownFileByHTTP(ByVal URL As String, FileName As String, Optional BlockSize As Long = 4096, Optional ResumeTransfer As Boolean) Dim xmlHttp As Object Dim bytData() As Byte Dim i As Long, fn As Integer, lTotalSize As Long '获得文件长度 Set xmlHttp = CreateObject("MSXML2.XMLHTTP") xmlHttp.open "HEAD", URL, False xmlHttp.send lTotalSize = xmlHttp.getResponseHeader("Content-Length") Set xmlHttp = Nothing '打开文件 fn = FreeFile() Open FileName For Binary As #fn '判断是否需要断点续传 If ResumeTransfer = True Then i = LOF(fn) Seek fn, i + 1 End If '分块下载数据，并保存到文件中 m_blnStop = False '重置中断标志 Do While i < lTotalSize And m_blnStop = False '没有使用For循环是因为需要下载数与实际下载数可能不一致 '获得文件数据 Set xmlHttp = CreateObject("MSXML2.XMLHTTP") xmlHttp.open "GET", URL, False xmlHttp.setRequestHeader "Referer", Left(URL, InStr(InStr(URL, "//") + 2, URL, "/") - 1) xmlHttp.setRequestHeader "Accept", "*/*" xmlHttp.setRequestHeader "User-Agent", "lyserver" xmlHttp.setRequestHeader "Range", "bytes=" & i & "-" & CStr(i + IIf(lTotalSize - i > BlockSize, BlockSize, lTotalSize - i) - 1) '分段 xmlHttp.setRequestHeader "Content-Type", "application/octet-stream" xmlHttp.setRequestHeader "Pragma", "no-cache" xmlHttp.setRequestHeader "Cache-Control", "no-cache" xmlHttp.send '转换为字节数组 bytData = xmlHttp.responseBody Set xmlHttp = Nothing '保存到文件中 Put fn, , bytData '重置下载开始位置 i = i + UBound(bytData) + 1 '释放控制权 DoEvents '显示进度 Debug.Print VBA.FormatPercent(i / lTotalSize) Loop Close fn End Sub Private Sub Command1_Click() '下载，由于在局域网内测试，因此分块设置较大（400K） DownFileByHTTP "HTTP://192.168.1.134/Vbe600chs1.rar", "c:/temp.rar", 409600, True If m_blnStop = True Then MsgBox "数据下载被中断！", vbCritical, "提示" Else MsgBox "数据下载完毕！", vbInformation, "提示" End If End Sub Private Sub Command2_Click() '中断下载 m_blnStop = True End Sub