用VB编写异步多线程下载程序

为了高效率地下载某站点的网页,我们可利用VB的InternetTransfer控件编写自己的下载程序,InternetTransfer控件支持超文本传输协议(HTTP)和文件传输协议(FTP)，使用InternetTransfer控件可以通过OpenURL或Execute方法连接到任何使用这两个协议的站点并检索文件。本程序使用多个InternetTransfer控件，使其同时下载某站点。并可判断文件是否已下载过或下载过的文件是否比服务器上当前的文件陈旧，以决定是否重新下载。所有下载的文件中的链接都做了调整，以便于本地查阅。
　　OpenURL方法以同步方式传输数据。同步指的是传输操作未完成之前，不能执行其它过程。这样数据传输就必须在执行其它代码之前完成。
　　而Execute方法以异步方式传输数据。在调用Execute方法时，传输操作与其它过程无关。这样，在调用Execute方法后，在后台接收数据的同时可执行其它代码。
　　用OpenURL方法能够直接得到可保存到磁盘的数据流，或者直接在TextBox控件中阅览（如果数据是文本格式的）。而用Execute方法获取数据，则必须用StateChanged事件监视该控件的连接状态。当达到适当的状态时，调用GetChunk方法从控件的缓冲区获取数据。
　　
　　首先，建立启始的http检索连接,
　　PublicgAsVariant
　　PublickAsVariant
　　PublicspathAsString
　　Dimlinks()AsString
　　g=0
　　spath=本地保存下载文件的路径
　　links(0)=启始URL
　　inet1.executelinks(0),"GET"'使用GET方法。
　　
　　事件监控子程序（每个InternetTransfer控件设置相对应的事件监控子程序）：
　　用StateChanged事件监视该控件的连接状态,当该请求已经完成，并且所有数据均已接收到时，调用GetChunk方法从控件的缓冲区获取数据。
　　PrivateSubInet1_StateChanged(ByValStateAsInteger)
　　'State=12时，使用GetChunk方法检索服务器的响应。
　　SelectCaseState
　　'...没有列举其它情况。
　　
　　CaseicResponseCompleted'12
　　'获取links(g)中的协议、主机和路径名。
　　addsuf=Left(links(g),InStrRev(links(g),"/"))
　　'获取links(g)中的文件名。
　　fname=Right(links(g),Len(links(g))-InStrRev(links(g),"/"))
　　'判断是否是超文本文件，是超文本文件则分析其中的链接，若不是则存为二进制文件。
　　IfInStr(1,fname,"htm",vbTextCompare)=TrueThen
　　'初始化用于保存文件的FileSystemObject对象。
　　Setfs=CreateObject("Scripting.FileSystemObject")
　　DimvtDataAsVariant'数据变量。
　　DimstrDataAsString:strData=""
　　DimbDoneAsBoolean:bDone=False
　　
　　'取得第一块。
　　vtData=inet1.GetChunk(1024,icString)
　　DoEvents
　　DoWhileNotbDone
　　strData=strData&vtData
　　DoEvents
　　'取得下一块。
　　vtData=inet1.GetChunk(1024,icString)
　　IfLen(vtData)=0Then
　　bDone=True
　　EndIf
　　Loop
　　
　　'获取文档中的链接并置于数组中。
　　DimiAsVariant
　　Dimpo1AsVariant
　　Dimpo2AsVariant
　　DimorilAsString
　　DimnewlAsString
　　Dimlmtime,ctime
　　po1=InStr(1,strData,"href=",vbTextCompare) 5
　　po2=1
　　DimnewstrAsString:newstr=""
　　DimwhostrAsString:whostr=""
　　i=0
　　DoWhilepo1>0
　　newstr=Mid(strData,po2,po1)
　　whostr=whostr newstr
　　po2=InStr(po1,strData,">",vbTextCompare)
　　'将原链接改为新链接
　　oril=Mid(strData,po1 1,po2-po1-1)
　　'如果有引号，去掉引号
　　ln=Replace(oril,"""","",vbTextCompare)
　　newl=Right(ln,Len(ln)-InStrRev(ln,"/"))
　　whostr=whostr&newl
　　Ifln<>""Then
　　'判定文件是否下载过。
　　Iffileexists(spath&newl)=FalseThen
　　links(i)=addsuf&ln
　　i=i 1
　　Else
　　lmtime=inet1.getheader("Last-modified")
　　Setf=fs.getfile(spath&newl)
　　ctime=f.datecreated
　　'判断文件是否更新
　　IfDateDiff("s",lmtime,ctime)<0Then
　　i=i 1
　　EndIf
　　EndIf
　　EndIf
　　po1=InStr(po2 1,strData,"href=",vbTextCompare) 5
　　Loop
　　newstr=Mid(strData,po2)
　　whostr=whostr newstr
　　
　　Seta=fs.createtextfile(spath&fname,True)
　　a.Writewhostr
　　a.Close
　　k=i
　　Else
　　DimvtDataAsVariant
　　Dimb()AsByte
　　DimbDoneAsBoolean:bDone=False
　　vtData=Inet2.GetChunk(1024,icByteArray)
　　DoWhileNotbDone
　　b()=b()&vtData
　　vtData=Inet2.GetChunk(1024,icByteArray)
　　IfLen(vtData)=0Then
　　bDone=True
　　EndIf
　　Loop
　　Openspath&fnameForBinaryAccessWriteAs#1
　　Put#1,,b()
　　Close#1
　　EndIf
　　Calldevjob'调用线程调度子程序
　　EndSelect
　　
　　EndSub
　　
　　PrivateSubInet2_StateChanged(ByValStateAsInteger)
　　...
　　endsub
　　
　　...
　　
　　线程调度子程序,g和是k公用变量，k为最后一个链接的数组索引加一，g初值为零，每次加一，直到处理完最后一个链接。
　　PrivateSubdevjob()
　　
　　IfNotg 1<kThenGoToreportline
　　IfInet1.StillExecuting=FalseThen
　　g=g 1
　　Inet1.Executelinks(g),"GET"
　　EndIf
　　IfNotg 1<kThenGoToreportline
　　IfInet2.StillExecuting=FalseThen
　　g=g 1
　　Inet2.Executelinks(g),"GET"
　　EndIf
　　
　　...
　　
　　reportline:
　　IfInet1.StillExecuting=FalseAndInet2.StillExecuting=FalseAnd...Then
　　MsgBox("下载结束。")
　　EndIf
　　EndSub->