用VB编写异步多线程下载程序,开源盛世-源代码下载网,一切精彩开放源代码尽在开源盛世！,开源,源代码,源码,VC,VB,Delphi,MapX,GIS,PDA,EVC,EVB,MapInfo,Visual C++,Visual Basic,开放源代码

　为了高效率地下载某站点的网页，我们可利用VB的Internet Transfer 控件编写自己的下载程序， Internet Transfer 控件支持超文本传输协议 (HTTP) 和文件传输协议 (FTP)，使用 Internet Transfer 控件可以通过 OpenURL 或 Execute 方法连接到任何使用这两个协议的站点并检索文件。本程序使用多个Internet Transfer 控件，使其同时下载某站点。并可判断文件是否已下载过或下载过的文件是否比服务器上当前的文件陈旧，以决定是否重新下载。所有下载的文件中的链接都做了调整，以便于本地查阅。

　　OpenURL 方法以同步方式传输数据。同步指的是传输操作未完成之前，不能执行其它过程。这样数据传输就必须在执行其它代码之前完成。

　　而 Execute 方法以异步方式传输数据。在调用 Execute 方法时，传输操作与其它过程无关。这样，在调用 Execute 方法后，在后台接收数据的同时可执行其它代码。

　　用 OpenURL 方法能够直接得到可保存到磁盘的数据流，或者直接在 TextBox 控件中阅览（如果数据是文本格式的）。而用 Execute 方法获取数据，则必须用 StateChanged 事件监视该控件的连接状态。当达到适当的状态时，调用 GetChunk 方法从控件的缓冲区获取数据。
　
　　首先，建立启始的http检索连接,

Public g As Variant
Public k As Variant
Public spath As String
Dim links() As String
g = 0
spath = 本地保存下载文件的路径
links(0)=启始URL
inet1.execute links(0), "GET" 注释：使用GET方法。

　　事件监控子程序（每个Internet Transfer 控件设置相对应的事件监控子程序）：
　
　　用StateChanged 事件监视该控件的连接状态, 当该请求已经完成，并且所有数据均已接收到时，调用 GetChunk 方法从控件的缓冲区获取数据。

Private Sub Inet1_StateChanged(ByVal State As Integer)
　注释：State = 12 时，使用 GetChunk 方法检索服务器的响应。
　Select Case State
　注释：...没有列举其它情况。
　
　Case icResponseCompleted 注释：12
　　注释：获取links(g)中的协议、主机和路径名。
　　addsuf = Left(links(g), InStrRev(links(g), "/"))
　　注释：获取links(g)中的文件名。
　　fname = Right(links(g), Len(links(g)) - InStrRev(links(g), "/"))
　　注释：判断是否是超文本文件，是超文本文件则分析其中的链接，若不是则存为二进制文件。
　　If InStr(1, fname, "htm", vbTextCompare) = True Then
　　注释：初始化用于保存文件的FileSystemObject对象。
　　　Set fs = CreateObject("scripting.FileSystemObject")
　　　Dim vtData As Variant 注释：数据变量。
　　　Dim strData As String: strData = ""
　　　Dim bDone As Boolean: bDone = False
　
　　　注释：取得第一块。
　　　vtData = inet1.GetChunk(1024, icString)
　　　DoEvents
　　　Do While Not bDone
　　　　strData = strData & vtData
　　　　DoEvents
　　　　注释：取得下一块。
　　　　vtData = inet1.GetChunk(1024, icString)
　　　　If Len(vtData) = 0 Then
　　　　　bDone = True
　　　　End If
　　　Loop
　
　　　注释：获取文档中的链接并置于数组中。
　　　Dim i As Variant
　　　Dim po1 As Variant
　　　Dim po2 As Variant
　　　Dim oril As String
　　　Dim newl As String
　　　Dim lmtime, ctime
　　　po1 = InStr(1, strData, "href=", vbTextCompare) + 5
　　　po2 = 1
　　　Dim newstr As String: newstr = ""
　　　Dim whostr As String: whostr = ""
　　　i = 0
　　　Do While po1 > 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
　　　　If ln <> "" Then
　　　　　注释：判定文件是否下载过。
　　　　　If fileexists(spath & newl) = False Then
　　　　　　links(i) = addsuf & ln
　　　　　　i = i + 1
　　　　　Else
　　　　　　lmtime = inet1.getheader("Last-modified")
　　　　　　Set f = fs.getfile(spath & newl)
　　　　　　ctime = f.datecreated
　　　　　　注释：判断文件是否更新
　　　　　　If DateDiff("s", lmtime, ctime) < 0 Then
　　　　　　　i = i + 1
　　　　　　End If
　　　　　End If
　　　　End If
　　　　po1 = InStr(po2 + 1, strData, "href=", vbTextCompare) + 5
　　　Loop
　　　newstr = Mid(strData, po2)
　　　whostr = whostr + newstr
　
　　　Set a = fs.createtextfile(spath & fname, True)
　　　a.Write whostr
　　　a.Close
　　　k = i
　　Else
　　　Dim vtData As Variant
　　　Dim b() As Byte
　　　Dim bDone As Boolean: bDone = False
　　　vtData = Inet2.GetChunk(1024, icByteArray)
　　　Do While Not bDone
　　　　b() = b() & vtData
　　　　vtData = Inet2.GetChunk(1024, icByteArray)
　　　　If Len(vtData) = 0 Then
　　　　　bDone = True
　　　　End If
　　　Loop
　　　Open spath & fname For Binary Access Write As #1
　　　Put #1, , b()
　　　Close #1
　　End If
　　Call devjob 注释：调用线程调度子程序
　End Select
　
End Sub
　
Private Sub Inet2_StateChanged(ByVal State As Integer)
...
end sub
　
...

　
　　线程调度子程序,g和是k公用变量，k为最后一个链接的数组索引加一，g初值为零，每次加一，直到处理完最后一个链接。

Private Sub devjob()
　
If Not g + 1 < k Then GoTo reportline
If Inet1.StillExecuting = False Then
　g = g + 1
　Inet1.Execute links(g), "GET"
End If
If Not g + 1 < k Then GoTo reportline
If Inet2.StillExecuting = False Then
　g = g + 1
　Inet2.Execute links(g), "GET"
End If
　
...
　
reportline:
If Inet1.StillExecuting = False And Inet2.StillExecuting = False And ... Then
　MsgBox ("下载结束。")
End If
End Sub

相关资料：Execute Method Example

The example shows a series of common FTP operations using the Execute method. The example assumes that three TextBox controls exist on the form. The first, txtURL contains the URL of the FTP server. The second, txtRemotePath, contains additional information needed by the particular command. The third, txtResponse, contains the response of the server.

Private Sub cmdChangeDirectory_Click()
   ' Change directory to txtRemotePath.
   Inet1.Execute txtURL.Text, "CD " & _
   txtRemotePath.Text
End Sub

Private Sub cmdDELETE_Click()
   ' Delete the directory in txtRemotePath.
   Inet1.Execute txtURL.Text, "DELETE " & _
   txtRemotePath.Text
End Sub

Private Sub cmdDIR_Click()
   Inet1.Execute txtURL.Text, "DIR FindThis.txt"
End Sub

Private Sub cmdGET_Click()
   Inet1.Execute txtURL.Text, _
   "GET GetThis.txt C:\MyDocuments\GotThis.txt"
End Sub

Private Sub cmdSEND_Click()
   Inet1.Execute txtURL.Text, _
   "SEND C:\MyDocuments\Send.txt SentDocs\Sent.txt"
End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)
   ' Retrieve server response using the GetChunk 
   ' method when State = 12.

   Dim vtData As Variant ' Data variable.
   Select Case State
   ' ... Other cases not shown.
   Case icError ' 11
      ' In case of error, return ResponseCode and 
      ' ResponseInfo.
      vtData = Inet1.ResponseCode & ":" & _
      Inet1.ResponseInfo
   Case icResponseCompleted ' 12
      Dim vtData As Variant
      Dim strData As String 
      Dim bDone As Boolean: bDone = False

      ' Get first chunk.
      vtData = Inet1.GetChunk(1024, icString)
      DoEvents

      Do While Not bDone
         strData = strData & vtData
         ' Get next chunk.
         vtData = Inet1.GetChunk(1024, icString)
         DoEvents

         If Len(vtData) = 0 Then
            bDone = True
         End If
      Loop
      txtData.Text = strData
   End Select
   
End Sub

软件：
文章：