2011-10-12 44 views
6

Tôi đã cố gắng sử dụng nhiều kỹ thuật khác nhau với điều này ... Một rằng hoạt động khá độc đáo nhưng vẫn gắn lên mã khi chạy được bằng cách sử dụng cuộc gọi api:tải tập tin đồng bộ từ bên trong VBA (Excel)

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 

tôi cũng đã sử dụng (thành công) mã để viết VBScript từ bên trong Excel và sau đó chạy với nó wScript và chờ đợi gọi lại. Nhưng một lần nữa điều này không hoàn toàn không đồng bộ và vẫn liên kết một số mã.

Tôi muốn tải xuống tệp trong lớp điều khiển sự kiện và mã VBA có thể thực hiện những việc khác trong vòng lặp lớn với "DoEvents". Khi một tệp được thực hiện, nó có thể kích hoạt cờ và mã có thể xử lý tệp đó trong khi chờ tệp khác.

Thao tác này sẽ kéo các tệp excel ra khỏi trang web Intranet. Nếu điều đó có ích.

Vì tôi chắc chắn ai đó sẽ hỏi, tôi không thể sử dụng bất cứ thứ gì ngoài VBA. Điều này sẽ được sử dụng tại nơi làm việc và 90% các máy tính được chia sẻ. Tôi rất nghi ngờ họ sẽ mùa xuân cho các chi phí kinh doanh của việc tôi Visual Studio hoặc. Vì vậy, tôi phải làm việc với những gì tôi có.

Mọi trợ giúp sẽ được đánh giá cao.

Trả lời

9

Bạn có thể làm điều này bằng XMLHTTP trong chế độ không đồng bộ và một lớp học để xử lý sự kiện của nó:

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

Mã có được giải quyết responseText, nhưng bạn có thể điều chỉnh mà sử dụng .responseBody. Đây là ví dụ (đồng bộ):

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 
+0

Sẽ không hoạt động khi tải xuống tệp Excel. Nhận lỗi "Giao thức không xác định". Trong ví dụ liên kết, anh ta nên sử dụng một FreeThreadedDomDocument vì nó được kích hoạt cho Asynch theo mặc định. Tuy nhiên, vấn đề tương tự, tuyệt vời khi tải xuống các trang web nhưng tôi không thể làm cho nó hoạt động đối với các tệp. – TheFuzzyGiggler

+0

Bạn đang tải xuống qua http, phải không? –

+0

Chỉ cần kiểm tra mã hiện có của tôi - hoạt động đối với tôi (giả sử HTTP) –

6

Không chắc đây có phải là thủ tục chuẩn hay không nhưng tôi không muốn làm lộn xộn câu hỏi của mình để mọi người đọc nó có thể hiểu rõ hơn.

Nhưng tôi đã tìm thấy giải pháp thay thế cho câu hỏi của mình phù hợp hơn với những gì tôi đã yêu cầu ban đầu. Cảm ơn Tim một lần nữa khi anh ấy đặt tôi đi đúng hướng và việc sử dụng ADODB.Stream của anh ấy là một phần quan trọng trong giải pháp của tôi.

Điều này sử dụng Dịch vụ WinHTTP của Microsoft 5.1 .DLL nên được bao gồm trong cửa sổ trong phiên bản này hoặc phiên bản khác, nếu không dễ dàng tải xuống.

tôi sử dụng đoạn mã sau trong một lớp được gọi là "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 

Sự khác biệt chính giữa này và những gì Tim đã được mô tả là WINHTTPRequest có riêng của nó được xây dựng trong các sự kiện mà tôi có thể quấn lên trong một gọn gàng lớp nhỏ và tái sử dụng bất cứ nơi nào. Đó là với tôi, một giải pháp thanh lịch hơn là gọi XMLHttp và sau đó chuyển nó sang một lớp để chờ nó.

Sau khi nó được bọc trong một lớp học như thế này có nghĩa là tôi có thể làm điều gì đó dọc theo dòng này ..

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 

đâu tôi chỉ lặp thông qua URL() với URL (1, N) là URL và URL (2, N) là vị trí lưu.

Tôi thừa nhận rằng có thể có thể được sắp xếp hợp lý một chút nhưng giờ đây công việc đó đã được thực hiện cho tôi. Chỉ cần tung ra giải pháp của tôi cho bất cứ ai quan tâm.

1

@TheFuzzyGiggler: +1: Cảm ơn bạn đã chia sẻ lại. Tôi biết nó một bài cũ nhưng có lẽ tôi làm cho ai đó hạnh phúc với addidion này để TheFuzzyGigglers mã (chỉ hoạt động trong lớp):

tôi bổ sung thêm hai thuộc tính:

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 

Trong lớp tôi có

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 

Bạn có thể truy cập đối tượng HTTP từ HTTPCallBack và thực hiện nhiều việc đẹp ở đây; điều chính là: nó hoàn toàn không đồng bộ bây giờ và dễ sử dụng. Hy vọng điều này sẽ giúp một người như OP đã giúp tôi.

Tôi đã phát triển thêm lớp này: kiểm tra my blog

Các vấn đề liên quan