vba: download files (website requires login)

notiz… damit ich das nicht nochmal erfinden muss. die webseite erfordert ein login, bevor man daten runterladen kann. das login formular muss man sich halt mal ansehen und die entsprechenden werte in einem POST request schicken. ich habe dazu einfach irgendein firefox plugin beim login mitlaufen lassen, welches den entsprechenden POST request aufzeichnet. das cookie muss man dann noch aus der antwort des webserver axtrahieren und beim anschliessenden download der dateien mitschicken.
mit excel 2003 und dem ie7 ging das noch ohne login in vba, wenn man sich vorher im browser eingeloggt hatte (mit urlmon o.ä. einfach runterladen). mit excel 2010 und ie9 muss man sich explizit (mit vba) einloggen um die dateien runterladen zu können.

Option Explicit
 
Sub DownloadData()
 
    Dim strSavePath As String
    Dim strURL As String
    Dim strURLDownload As String
    Dim strHeaders As String
    Dim strResult As String
    Dim strRequest As Variant
    Dim objXMLhttp: Set objXMLhttp = CreateObject("msxml2.xmlhttp")
    Dim strUsername As String
    Dim strPassword As String
    Dim strFileToSave As String
    Dim xArr As Variant
    Dim yArr As Variant
    Dim strTheCookie As String
    Dim strCookie As String
    Dim objStream: Set objStream = CreateObject("ADODB.Stream")
    Dim i
    Dim WkSh As Worksheet ' das Quell-Tabellenblatt - die Herkunft der Daten
    Dim lZeile As Long
 
    ' Variablen
    Set WkSh = ThisWorkbook.Worksheets("DOWNLOADFILES") ' den Tabellenblattnamen ggf. anpassen!
    ' Format in dem Tabellenblatt DOWNLOADFILES.. einfach eine Auflistung der Download URLs:
    'http://www.website.com/download/data/file_1.xls
    'http://www.website.com/download/data/file_2.xls
    'http://www.website.com/download/data/file_3.xls
 
    ' Pfad zum speichern der XLS Dateien 
    strSavePath = "c:\temp\"
    strUsername = "vorname.nachname%40domain.tld" ' URL encoded: @ = %40
    strPassword = "mypassword"
    ' Login URL
    strURL = "http://www.website.com/login-user"
    ' mitgehörter request header (mit Firefox Plugin aufgezeichnet)
    ' Benutzername und Passwort durch Variablen ersetzt
    strRequest = "viewFrom=viewLOGIN&forward=%2Fbackend%2Findex.html&referer=%2Flogin.html&username= " & strUsername & "&password=" & strPassword & "&actionSUBMIT.x=0&actionSUBMIT.y=0"
 
    ' Login
    With objXMLhttp
        .Open "POST", strURL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send strRequest
    End With
 
    strHeaders = objXMLhttp.getAllResponseHeaders()
 
    ' ggf Response speichern um das Cookie anzuschauen
    'Open "C:\temp\response.txt" For Output As #1
    '  Print #1, , strHeaders
    'Close
 
    ' Beispiel Cookie aus strHeaders
    'Set-Cookie: BALANCERID=b.cocoon0a0815; Expires=Tue, 07-Aug-2012 08:00:00 GMT; Path=/
 
    ' Cookie extrahieren
    xArr = Split(strHeaders, "Set-Cookie: ")
    For i = 1 To UBound(xArr)
        strTheCookie = Left(xArr(i), InStr(xArr(i), "Path=/") - 2)
        strCookie = strCookie & " " & strTheCookie
    Next
    yArr = Split(strCookie, ";")
    strCookie = yArr(0)
 
   For lZeile = 1 To WkSh.Cells(Rows.Count, 1).End(xlUp).Row
 
        ' Downloadlink
        strURLDownload = WkSh.Range("A" & lZeile).Value
 
        ' Dateiname aus URL extrahieren
        strFileToSave = Mid$(strURLDownload, InStrRev(strURLDownload, "/") + 1)
 
        ' Download der xls Datei
        With objXMLhttp
            .Open "GET", strURLDownload, False
            .setRequestHeader "cache-control", "no-cache, must revalidate"
            'Cookie 2mal setzen... Bug: http://support.microsoft.com/kb/290899
            .setRequestHeader "Cookie", strCookie
            .setRequestHeader "Cookie", strCookie
            .send
        End With
 
        ' Speichern der xls Datei als Binary
        With objStream
            .Type = 1 ' adTypeBinary
            .Open
            .Write objXMLhttp.responseBody
            .SaveToFile strSavePath & strFileToSave, 2 ' adSaveCreateOverWrite
        End With
        objStream.Close
 
   Next lZeile
 
    Set objStream = Nothing
    Set objXMLhttp = Nothing
 
End Sub

07. August 2012 by sd
Categories: Uncategorized | Tags: , | Leave a comment

Leave a Reply

Required fields are marked *