Асинхронная загрузка файлов из VBA (Excel)

Question

Я уже пробовал использовать много разных техник с этим ... Тот, который работает довольно хорошо, но все еще связывает код при запуске, использует вызов 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

Я также использовал (успешно) код для написания vbscript из Excel, а затем запуска с ним wscript и ожидания обратного вызова.Но опять же, это не совсем асинхронно и все еще связывает часть кода.

Я бы хотел, чтобы файлы загружались в управляемом событиями классе, а код VBA мог выполнять другие задачи в большом цикле с помощью «DoEvents».Когда один файл готов, он может активировать флаг, и код может обработать этот файл в ожидании другого.

Это вытягивает файлы Excel с сайта интрасети.Если это поможет.

Поскольку я уверен, что кто-то спросит, я не могу использовать ничего, кроме VBA.Это будет использоваться на рабочем месте, и 90% компьютеров являются общими.Я очень сомневаюсь, что они также появятся за бизнес-затраты на приобретение меня Visual Studio.Поэтому я должен работать с тем, что у меня есть.

Любая помощь будет принята с благодарностью.

Answer 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

Answer 2

Не уверен, является ли это стандартной процедурой или нет, но я не хотел чрезмерно загромождать мой вопрос, чтобы люди, читающие его, могли лучше понять его.

Но я нашел альтернативное решение моего вопроса, которое больше соответствует тому, что я первоначально запрашивал. Еще раз спасибо Тиму за то, что он поставил меня на правильный путь, и его использование 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

Основное различие между этим и тем, что описывал Тим, состоит в том, что 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) - это место сохранения.

Я признаю, что, возможно, это можно немного упростить, но сейчас мне нужно выполнить работу. Просто подбрасываю свое решение всем, кому интересно.

Answer 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

Вы можете получить доступ к объекту HTTP из HTTPCallBack и сделать здесь много прекрасных вещей; главное: теперь он совершенно асинхронный и простой в использовании. Надеюсь, это поможет кому-то, так как ОП мне помог.

Я разработал это далее в классе: проверьте мой блог