从 VBA (Excel) 中的异步文件下载答案

【问题标题】：Asynchronous File Downloads from Within VBA (Excel)从 VBA (Excel) 中的异步文件下载
【发布时间】：2011-10-12 23:45:58
【问题描述】：

我已经尝试过对此使用许多不同的技术...一种运行良好但在运行时仍会占用代码的方法是使用 api 调用：

Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

和

IF URLDownloadToFile(0, "URL", "FilePath", 0, 0) Then
End If

我还使用（成功）代码从 Excel 中编写 vbscript，然后使用它运行 wscript 并等待回调。但这又不是完全异步的，仍然会占用一些代码。

我希望在事件驱动类中下载文件，并且 VBA 代码可以使用“DoEvents”在一个大循环中执行其他操作。当一个文件完成时，它可以触发一个标志，代码可以在等待另一个文件的同时处理该文件。

这是从 Intranet 站点中提取 excel 文件。如果有帮助的话。

因为我确定有人会问，所以我只能使用 VBA。这将在工作场所使用，并且 90% 的计算机是共享的。我非常怀疑他们是否会因为获得 Visual Studio 的商业费用而跃跃欲试。所以我必须利用我所拥有的。

任何帮助将不胜感激。

【问题讨论】：

标签： vba asynchronous download

【解决方案1】：

您可以在异步模式下使用 xmlhttp 和一个类来处理其事件：

http://www.dailydoseofexcel.com/archives/2006/10/09/async-xmlhttp-calls/

那里的代码处理 responseText，但您可以调整它以使用 .responseBody。这是一个（同步）示例：

Sub FetchFile(sURL As String, sPath)
 Dim oXHTTP As Object
 Dim oStream As Object


    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    Set oStream = CreateObject("ADODB.Stream")
    Application.StatusBar = "Fetching " & sURL & " as " & sPath
    oXHTTP.Open "GET", sURL, False
    oXHTTP.send
    With oStream
        .Type = 1 'adTypeBinary
        .Open
        .Write oXHTTP.responseBody
        .SaveToFile sPath, 2 'adSaveCreateOverWrite
        .Close
    End With
    Set oXHTTP = Nothing
    Set oStream = Nothing
    Application.StatusBar = False


End Sub

【讨论】：

下载 Excel 文件时不起作用。收到“未知协议”错误。在链接示例中，他应该使用 FreeThreadedDomDocument，因为它默认启用了异步。同样的问题，非常适合下载网页，但我无法让它用于文件。
嗯，你是对的。只是尝试了几个不同的链接，它工作。不知道为什么原版没有...我希望有一种更自然的方式来做到这一点，最好是使用一个拥有自己事件的对象。有点像 ADODB 对 Connection 和 Recordset 所做的。但这应该可以正常工作。谢谢！

【解决方案2】：

不确定这是否是标准程序，但我不想过于混乱我的问题，以便阅读它的人可以更好地理解它。

但我找到了一个更符合我最初要求的问题的替代解决方案。再次感谢 Tim，他让我走上了正轨，他对 ADODB.Stream 的使用是我解决方案的重要组成部分。

这使用了 Microsoft WinHTTP Services 5.1 .DLL，它应该包含在一个或另一个版本的 windows 中，如果没有，它很容易下载。

我在一个名为“HTTPRequest”的类中使用以下代码

Option Explicit

Private WithEvents HTTP As WinHttpRequest
Private ADStream As ADODB.Stream
Private HTTPRequest As Boolean
Private I As Double
Private SaveP As String

Sub Main(ByVal URL As String)
HTTP.Open "GET", URL, True
HTTP.send
End Sub

Private Sub Class_Initialize()
Set HTTP = New WinHttpRequest
Set ADStream = New ADODB.Stream
End Sub

Private Sub HTTP_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String)
Debug.Print ErrorNumber
Debug.Print ErrorDescription
End Sub


Private Sub HTTP_OnResponseFinished()
    'Tim's code Starts'
    With ADStream
        .Type = 1
        .Open
        .Write HTTP.responseBody
        .SaveToFile SaveP, 2
        .Close
    End With
    'Tim's code Ends'

HTTPRequest = True
End Sub

Private Sub HTTP_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
End Sub

Private Sub Class_Terminate()
Set HTTP = Nothing
Set ADStream = Nothing
End Sub

Property Get RequestDone() As Boolean
RequestDone = HTTPRequest
End Property

Property Let SavePath(ByVal SavePath As String)
SaveP = SavePath
End Property

这与 Tim 所描述的主要区别在于 WINHTTPRequest 有它自己的内置事件，我可以将其封装在一个整洁的小类中并在任何地方重用。对我来说，这是一个比调用 XMLHttp 然后将其传递给一个类等待它更优雅的解决方案。

将它包含在这样的类中意味着我可以按照这种方式做一些事情..

Dim HTTP(10) As HTTPRequest
Dim URL(2, 10) As String
Dim I As Integer, J As Integer, Z As Integer, X As Integer

    While Not J > I
        For X = 1 To I
            If Not TypeName(HTTP(X)) = "HTTPRequest" And Not URL(2, X) = Empty Then
                Set HTTP(X) = New HTTPRequest
                HTTP(X).SavePath = URL(2, X)
                HTTP(X).Main (URL(1, X))
                Z = Z + 1
            ElseIf TypeName(HTTP(X)) = "HTTPRequest" Then
                If Not HTTP(X).RequestDone Then
                    Exit For
                Else
                    J = J + 1
                    Set HTTP(X) = Nothing
                End If
            End If
        Next
        DoEvents
    Wend

我只是遍历 URL()，其中 URL(1,N) 是 URL，而 URL(2,N) 是保存位置。

我承认这可能会简化一点，但它现在可以为我完成工作。只是把我的解决方案扔给有兴趣的人。

【讨论】：

【解决方案3】：

@TheFuzzyGiggler：+1：感谢您的回复。我知道这是一篇旧文章，但也许我对 TheFuzzyGigglers 代码的这个附加部分感到满意（仅在类中有效）：

我添加了两个属性：

Private pCallBack as string
Private pCallingObject as object

Property Let Callback(ByVal CB_Function As String)
 pCallBack = CB_Function
End Property

Property Let CallingObject(set_me As Object)
 Set pCallbackObj = set_me
End Property

'and at the end of HTTP_OnResponseFinished()

CallByName pCallbackObj, pCallback, VbMethod

在我的课堂上

 Private EntryCollection As New Collection

 Private Sub Download(ByVal fromURL As String, ByVal toPath As String)
 Dim HTTPx As HTTPRequest
 Dim i As Integer
  Set HTTPx = New HTTPRequest
  HTTPx.SavePath = toPath
  HTTPx.Callback = "HTTPCallBack"
  HTTPx.CallingObject = Me
  HTTPx.Main fromURL
  pHTTPRequestCollection.Add HTTPx
End Sub

Sub HTTPCallBack()
Dim HTTPx As HTTPRequest
Dim i As Integer
For i = pHTTPRequestCollection.Count To 1 Step -1
  If pHTTPRequestCollection.Item(i).RequestDone Then pHTTPRequestCollection.Remove i
Next
End Sub

您可以从 HTTPCallBack 访问 HTTP 对象并在这里做很多漂亮的事情；最主要的是：它现在完全异步且易于使用。希望这可以帮助某人，因为 OP 帮助了我。

我将它进一步开发成一个类：检查my blog

【讨论】：