用VB编写异步多线程下载程序 >>三湘时空-IT知识库[www.sxsky.net]

为了高效率地下载某站点的网页,我们可利用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->

上一篇:用VB编写标准CGI程序（上）

下一篇:PING一个IP地址（向它发送一个数据包并等待回应)）