ASP无组件上传带进度条

<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%Option Explicit%>

<%
'================================================================
'
'                                带进度条的ASP无组件断点续传下载
'
'================================================================
'简介：
'        1)利用xmlhttp方式
'        2)无组件
'        3)异步方式获取，节省服务器资源
'        4)服务器到服务器的文件传送。(当然，你自己电脑上的IIS也是http服务器)
'        5)支持断点续传
'        6)分段下载
'        7)使用缓冲区，提升下载速度
'        8)支持大文件下载(速度我就不说了，你可以测，用事实说话)
'        9)带进度条：下载百分比、下载量、即时下载速度、平均下载速度
'
'用法：
'        设置好下面的三个变量，RemoteFileUrl、LocalFileUrl、RefererUrl
'
'================================================================
%>

<%'-----------------------------以下为设置部分--------------------------------%>
<%Server.Scripttimeout = 24 * 60 * 60        '脚本超时设置，这里设为24小时%>
<%
Dim RemoteFileUrl        '远程文件路径
Dim LocalFileUrl        '本地文件路径,相对路径，可以包含/及..

'速度问题注意：下面这个测试文件是在“网通”服务器上！！！
RemoteFileUrl = "http://hdt.driversky.com/down/foxmail60beta2.exe"
LocalFileUrl = "foxmail60beta2.exe"


Dim RefererUrl
'该属性设置文件下载的引用页，
'某些网站只允许通过他们网站内的连接下载文件，
'这些网站的服务器判断用户是否是在他们网站内点击的文件链接就是靠这个属性。
RefererUrl = "http://www.skycn.com/crack_skycn.html"        '若远程服务器未限制，可留空


Dim BlockSize        '分段下载的块大小
Dim BlockTimeout        '下载块的超时时间(秒)

BlockSize = 128 * 1024        '128K，按1M带宽计算的每秒下载量（可根据自己的带宽设置，带宽除以8），建议不要设的太小
BlockTimeout = 64        '应当根据块的大小来设置。这里设为64秒。如果128K的数据64秒还下载不完(按每秒2K保守估算)，则超时。


Dim PercentTableWidth        '进度条总宽度

PercentTableWidth = 560
%>
<%'-----------------------------以上为设置部分--------------------------------%>

<%
'***********************************************************************
'                                        ！！！以下内容无须修改！！！
'***********************************************************************
%>
<%
Dim LocalFileFullPhysicalPath        '本地文件在硬盘上的绝对路径

LocalFileFullPhysicalPath = Server.Mappath(LocalFileUrl)
%>

<%
Dim http,ados

On Error Resume Next
Set http = Server.CreateObject("Msxml2.ServerXMLHTTP.7.0")
If Err Then
        Err.Clear

        Set http = Server.CreateObject("Msxml2.ServerXMLHTTP.6.0")
        If Err Then
                Err.Clear

                Set http = Server.CreateObject("Msxml2.ServerXMLHTTP.5.0")
                If Err Then
                        Err.Clear

                        Set http = Server.CreateObject("Msxml2.ServerXMLHTTP.3.0")
                        If Err Then
                                Err.Clear

                                Set http = Server.CreateObject("Msxml2.ServerXMLHTTP")
                                If Err Then
                                        Err.Clear
                                        Response.Write "服务器不支持Msxml，本程序无法运行！"
                                        Response.End
                                End If
                        End If
                End If
        End If
End If
On Error Goto 0

Set ados = Server.CreateObject("Adodb.Stream")
%>

<%
Dim RangeStart        '分段下载的开始位置
Dim fso

Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FileExists(LocalFileFullPhysicalPath) Then        '判断要下载的文件是否已经存在
  RangeStart = fso.GetFile(LocalFileFullPhysicalPath).Size        '若存在，以当前文件大小作为开始位置
Else
  RangeStart = 0        '若不存在，一切从零开始
  fso.CreateTextFile(LocalFileFullPhysicalPath).Close        '新建文件
End If
Set fso = Nothing
%>

<%
Dim FileDownStart        '本次下载的开始位置
Dim FileDownEnd        '本次下载的结束位置
Dim FileDownBytes        '本次下载的字节数
Dim DownStartTime        '开始下载时间
Dim DownEndTime        '完成下载时间
Dim DownAvgSpeed        '平均下载速度

Dim BlockStartTime        '块开始下载时间
Dim BlockEndTime        '块完成下载时间
Dim BlockAvgSpeed        '块平均下载速度

Dim percentWidth        '进度条的宽度
Dim DownPercent        '已下载的百分比

FileDownStart = RangeStart
%>

<%
Dim adosCache        '数据缓冲区
Dim adosCacheSize        '缓冲区大小

Set adosCache = Server.CreateObject("Adodb.Stream")
adosCache.Type = 1        '数据流类型设为字节
adosCache.Mode = 3        '数据流访问模式设为读写
adosCache.Open
adosCacheSize = 4 * 1024 * 1024        '设为4M，获取的数据先放到(内存)缓冲区中，当缓冲区满的时候数据写入磁盘

'若在自己的电脑上运行本程序，当下载百兆以上级别的大文件的时候，可设置大的缓冲区
'当然，也不要设的太大，免得发生(按下浏览器上的停止按钮或断电等)意外情况导致缓冲区中的数据没有存盘，那缓冲区中的数据就白下载了
%>

<%
'先显示html头部
Response.Clear
Call HtmlHead()
Response.Flush
%>

<%
Dim ResponseRange        '服务器返回的http头中的"Content-Range"
Dim CurrentLastBytes        '当前下载的结束位置(即ResponseRange中的上限)
Dim TotalBytes        '文件总字节数
Dim temp

'分段下载
DownStartTime = Now()

Do
        BlockStartTime = Timer()

        http.open "GET",RemoteFileUrl,true,"",""        '用异步方式调用serverxmlhttp

        '构造http头
        http.setRequestHeader "Referer",RefererUrl
        http.setRequestHeader "Accept","*/*"
        http.setRequestHeader "User-Agent","Baiduspider+(+http://www.baidu.com/search/spider.htm)"        '伪装成Baidu
        'http.setRequestHeader "User-Agent","Googlebot/2.1 (+http://www.google.com/bot.html)"        '伪装成Google
        http.setRequestHeader "Range","bytes=" & RangeStart & "-" & Cstr(RangeStart + BlockSize - 1)        '分段关键
        http.setRequestHeader "Content-Type","application/octet-stream"
        http.setRequestHeader "Pragma","no-cache"
        http.setRequestHeader "Cache-Control","no-cache"

        http.send        '发送

        '循环等待数据接收
        While (http.readyState <> 4)
                '判断是否块超时
                temp = Timer() - BlockStartTime
                If (temp > BlockTimeout) Then
                        http.abort
                        Response.Write "<script>document.getElementById(""status"").innerHTML=""<strong>错误：数据下载超时，建议重试。</strong>"";</script>" & vbNewLine & "</body></html>"
                        Call ErrHandler()
                        Call CloseObject()
                        Response.End
                End If

                http.waitForResponse 1000        '等待1000毫秒
        Wend

        '检测状态
        If http.status = 416 Then        '服务器不能满足客户在请求中指定的Range头。应当是已下载完毕。
                FileDownEnd = FileDownStart        '设置一下FileDownEnd，免得后面的FileDownBytes计算出错
                Call CloseObject()
                Exit Do
        End If

        '检测状态
        If http.status > 299 Then        'http出错
                Response.Write "<script>document.getElementById(""status"").innerHTML=""<strong>http错误：" & http.status & " " & http.statusText & "</strong>"";</script>" & vbNewLine & "</body></html>"
                Call ErrHandler()
                Call CloseObject()
                Response.End
        End If

        '检测状态
        If http.status <> 206 Then        '服务器不支持断点续传
                Response.Write "<script>document.getElementById(""status"").innerHTML=""<strong>错误：服务器不支持断点续传！</strong>"";</script>" & vbNewLine & "</body></html>"
                Call ErrHandler()
                Call CloseObject()
                Response.End
        End If

        '检测缓冲区是否已满
        If adosCache.Size >= adosCacheSize Then
                '打开磁盘上的文件
                ados.Type = 1        '数据流类型设为字节
                ados.Mode = 3        '数据流访问模式设为读写
                ados.Open
                ados.LoadFromFile LocalFileFullPhysicalPath        '打开文件
                ados.Position = ados.Size        '设置文件指针初始位置

                '将缓冲区数据写入磁盘文件
                adosCache.Position = 0
                ados.Write adosCache.Read
                ados.SaveToFile LocalFileFullPhysicalPath,2        '覆盖保存
                ados.Close

                '缓冲区复位
                adosCache.Position = 0
                adosCache.SetEOS
        End If

        '保存块数据到缓冲区中
        adosCache.Write http.responseBody        '写入数据

        '判断是否全部(块)下载完毕
        ResponseRange = http.getResponseHeader("Content-Range")        '获得http头中的"Content-Range"
        If ResponseRange = "" Then        '没有它就不知道下载完了没有
                Response.Write "<script>document.getElementById(""status"").innerHTML=""<strong>错误：文件长度未知！</strong>"";</script>" & vbNewLine & "</body></html>"
                Call CloseObject()
                Response.End
        End If
        temp = Mid(ResponseRange,Instr(ResponseRange,"-")+1)        'Content-Range是类似123-456/789的样子
        CurrentLastBytes = Clng(Left(temp,Instr(temp,"/")-1))        '123是开始位置，456是结束位置
        TotalBytes = Clng(Mid(temp,Instr(temp,"/")+1))        '789是文件总字节数
        If TotalBytes - CurrentLastBytes = 1 Then
                FileDownEnd = TotalBytes

                '将缓冲区数据写入磁盘文件
                ados.Type = 1        '数据流类型设为字节
                ados.Mode = 3        '数据流访问模式设为读写
                ados.Open
                ados.LoadFromFile LocalFileFullPhysicalPath        '打开文件
                ados.Position = ados.Size        '设置文件指针初始位置
                adosCache.Position = 0
                ados.Write adosCache.Read
                ados.SaveToFile LocalFileFullPhysicalPath,2        '覆盖保存
                ados.Close

                Response.Write "<script>document.getElementById(""downsize"").innerHTML=""" & TotalBytes & """;</script>" & vbNewLine
                Response.Flush
                Call CloseObject()
                Exit Do        '结束位置比总大小少1就表示传输完成了
        End If

        '调整块开始位置，准备下载下一个块
        RangeStart = RangeStart + BlockSize

        '计算块下载速度、进度条宽度、已下载的百分比
        BlockEndTime = Timer()
        temp = (BlockEndTime - BlockStartTime)
        If temp > 0 Then
                BlockAvgSpeed = Int(BlockSize / 1024 / temp)
        Else
                BlockAvgSpeed = ""
        End If
        percentWidth = Int(PercentTableWidth * RangeStart / TotalBytes)
        DownPercent = Int(100 * RangeStart / TotalBytes)

        '更新进度条
        Response.Write "<script>document.getElementById(""downpercent"").innerHTML=""" & DownPercent & "%"";document.getElementById(""downsize"").innerHTML=""" & RangeStart & """;document.getElementById(""totalbytes"").innerHTML=""" & TotalBytes & """;document.getElementById(""blockavgspeed"").innerHTML=""" & BlockAvgSpeed & """;document.getElementById(""percentdone"").style.width=""" & percentWidth & """;</script>" & vbNewLine
        Response.Flush
Loop While Response.IsClientConnected

If Not Response.IsClientConnected Then
        Response.End
End If

DownEndTime = Now()
FileDownBytes = FileDownEnd - FileDownStart
temp = DateDiff("s",DownStartTime,DownEndTime)
If (FileDownBytes <> 0) And (temp <> 0) Then
        DownAvgSpeed = Int((FileDownBytes / 1024) / temp)
Else
        DownAvgSpeed = ""
End If

'全部下载完毕后更新进度条
Response.Write "<script>document.getElementById(""downpercent"").innerHTML=""100%"";document.getElementById(""percentdone"").style.width=""" & PercentTableWidth & """;document.getElementById(""percent"").style.display=""none"";document.getElementById(""status"").innerHTML=""<strong>下载完毕！用时：" & S2T(DateDiff("s",DownStartTime,DownEndTime)) & "，平均下载速度：" & DownAvgSpeed & "K/秒</strong>"";</script>" & vbNewLine
%>

</body>
</html>

<%
Sub CloseObject()
        Set ados = Nothing
        Set http = Nothing
        adosCache.Close
        Set adosCache = Nothing
End Sub
%>

<%
'http异常退出处理代码
Sub ErrHandler()
        Dim fso

        Set fso = Server.CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(LocalFileFullPhysicalPath) Then        '判断要下载的文件是否已经存在
                If fso.GetFile(LocalFileFullPhysicalPath).Size = 0 Then        '若文件大小为0
                        fso.DeleteFile LocalFileFullPhysicalPath        '删除文件
                End If
        End If
        Set fso = Nothing
End Sub
%>

<%Sub HtmlHead()%>
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<title>带进度条的ASP无组件断点续传下载</title>
</head>
<body>
<div id="status">正在下载 <span style="color:blue"><%=RemoteFileUrl%></span> ,请稍候...</div>
<div> </div>
<div id="progress">已完成：<span id="downpercent" style="color:green"></span> <span id="downsize" style="color:red"><%=RangeStart%></span> / <span id="totalbytes" style="color:blue"></span> 字节(<span id="blockavgspeed"></span>K/秒)</div>
<div> </div>
<div id="percent" align="center" style="display:''">
        <table style="border-collapse:collapse;" border="1" bordercolor="#666666" cellpadding="0" cellspacing="0" width="<%=PercentTableWidth%>" align="center" bgcolor="#eeeeee">
                <tr height="20">
                        <td>
                                <table border="0" width="" cellspacing="1" bgcolor="#0033FF" id="percentdone">
                                        <tr>
                                                <td> <td>
                                        </tr>
                                </table>
                        </td>
                </tr>
        </table>
</div>
<%End Sub%>

<%
'--------------------------------------------------------------------
'将秒数转换为"x小时y分钟z秒"形式
'--------------------------------------------------------------------
Function S2T(ByVal s)
        Dim x,y,z,t
        If s < 1 Then
                S2T = (s * 1000) & "毫秒"
        Else
                s = Int(s)
                x = Int(s / 3600)
                t = s - 3600 * x
                y = Int(t / 60)
                z = t - 60 * y
                If x > 0 Then
                        S2T = x & "小时" & y & "分" & z & "秒"
                Else
                        If y > 0 Then
                                S2T = y & "分" & z & "秒"
                        Else
                                S2T = z & "秒"
                        End If
                End If
        End If
End Function
'--------------------------------------------------------------------
%>