Przykład importu danych z tabeli HTML ze stronki wymagającej
logowania. Z wykorzystaniem: WinHttp.WinHttpRequest oraz InternetExplorer.Application
  strona główna:
A po co ten Excel ;-)
 
 
 
 
 
Zadanie, któremu przyglądałem się jakiś czas, ale jakoś nie miałem okazji nigdy się z nim zmierzyć.. i trafiła się okazja :-)  
Chcąc zapisać swoje spostrzeżenia i sposób realizacji zadania postanowiłem się tym z Wami podzielić. :-)  
Zadanie będzie polegało na imporcie danych z tabeli HTML. Utrudnieniem będzie fakt, że żeby pobrać wymagalne dane trzeba się  
zalogować :-). Stronką będzie www.pmanager.org, a do pobrania będą trzy pierwsze tabele Listy transferowej.  
 
Pierwsze rozwiązanie to wykorzystanie InternetExplorer.Application  
 
Function TabelaHTML() As Variant  
 
                              
    On Error GoTo TabelaHTML_Error  
              
    'Info do wczesnego wiązania:  
    'Referencje do:  
    '   Microsoft HTML Object Library  
    '   Microsoft Internet Controls  
            
 
    Dim ieApp As Object 'SHDocVw.InternetExplorer  
    Dim objHTMLDoc As Object 'MSHTML.HTMLDocument  
    Dim colTags As Object  
      
      
    Dim ieTables As Object, ieTable As Object 'MSHTML.HTMLTable  
    Dim ieRows As Object, ieRow As Object 'MSHTML.HTMLTableRow  
    Dim ieCells As Object, ieCell As Object 'MSHTML.HTMLTableCell  
              
    Const READYSTATE_COMPLETE = 4  
              
    Dim tbl() As Variant, i As Long, j As Long  
              
    Set ieApp = CreateObject("InternetExplorer.Application")  
    With ieApp  
        .navigate URL:="http://www.pmanager.org"  
        Do Until .readyState = READYSTATE_COMPLETE: Loop  
        Set objHTMLDoc = .Document  
        With objHTMLDoc  
            .getElementById("utilizador").Value = "ma######"  
            .getElementById("password").Value = "sk#######"  
            .getElementsByClassName("btn btn-or pull-right").Item(0).Click  
            Do While ieApp.Busy: Sleep 100: Loop  
        End With  
          
        'Sleep lngSleep  
    
        Const strURL2 As String = "http://www.pmanager.org/procurar.asp?action=proc_jog&" & _
                                  "nome=&pos=0&nacional=-1&lado=-1&idd_op=%3C&idd=Wszystko&" & _
                                  "temp_op=%3C&temp=Wszystko&expe_op=%3E=&expe=Wszystko&con_op=%3C&" & _
                                  "con=Wszystko&pro_op=%3E&pro=Wszystko&vel_op=%3E&vel=Wszystko&forma_op=%3E&" & _
                                  "forma=Wszystko&cab_op=%3E&cab=Wszystko&ord_op=%3C=&ord=Wszystko&cul_op=%3E&" & _
                                  "cul=Wszystko&pre_op=%3C=&pre=Wszystko&forca_op=%3E&forca=Wszystko&" & _
                                  "lesionado=Wszystko&prog_op=%3E&prog=Wszystko&tack_op=%3E&tack=Wszystko&" & _
                                  "internacional=Wszystko&passe_op=%3E&passe=Wszystko&pais=-1&rem_op=%3E&" & _
                                  "rem=Wszystko&tec_op=%3E&tec=Wszystko&jmaos_op=%3E&jmaos=Wszystko&saidas_op=%3E&" & _
                                  "saidas=Wszystko&reflexos_op=%3E&reflexos=Wszystko&agilidade_op=%3E&agilidade=Wszystko&" & _
                                  "B1=Pesquisar&field=&pid=1&sort=0&pv=1&qual_op=%3E&qual=Wszystko&talento=Wszystko"
        .Navigate2 strURL2
        Do Until .readyState = READYSTATE_COMPLETE: Loop  
       ' .Visible = True: Stop  
      
        Set ieTables = .Document.all.tags("TABLE")  
        Set ieTable = ieTables(0)  
        Set ieRows = ieTable.Rows  
        For Each ieRow In ieRows  
            i = i + 1  
            Set ieCells = ieRow.Cells  
            For Each ieCell In ieCells  
                j = j + 1  
                If i = 1 And j = 1 Then  
                    ReDim tbl(1 To ieTable.Rows.Length, _  
                              1 To ieRow.Cells.Length)  
                End If  
                If j > UBound(tbl, 2) Then  
                    ReDim Preserve tbl(1 To ieTable.Rows.Length, _  
                                       1 To ieRow.Cells.Length)  
                End If  
                tbl(i, j) = ieCell.innerText  
            Next  
            j = 0  
        Next  
    End With  
    Set ieApp = Nothing  
              
    TabelaHTML = tbl  
              
TabelaHTML_Exit:  
    On Error Resume Next  
              
    If Not ieApp Is Nothing Then  
        ieApp.navigate "http://www.pmanager.org/logout.asp"  
        ieApp.Quit  
        Set ieApp = Nothing  
    End If  
              
    Set ieTables = Nothing  
    Set ieRows = Nothing  
    Set ieCells = Nothing  
      
    Exit Function  
              
TabelaHTML_Error:  
     MsgBox "Błąd Nr - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - Wig20zGPW"  
     Resume TabelaHTML_Exit  
      
End Function  
 
Jednak pokazuję Wam tę procedurę żeby udowodnić że się, po prostu, da :-) Sposób dość powolny, przez fakt że procedura  
wykorzystuje niewidoczną instancję IE a ta oprócz wymagalnych danych ładuje wszystko co przewidział twórca strony: reklamy,..  
Sposobem, dla mnie może nie zupełnie, nowym jest wykorzystanie WinHttp.WinHttpRequest.5.1.  
I na procedurze realizującej zadanie poprzez wykorzystanie ww. obiektu przyjrzymy się dokładniej.  
 
Dwa słowa do wstępnego wyjaśnienia przyjętej konwencji: Kod przerywam screen'ami okna Immediate po wydrukowaniu do niego  
elementów ResponseHeaders. Po prawej screen'y z FireBug'a z paramentami wysyłanymi na każdym etapie pobierania danych.  
 
Sub TabelaHTMLvWinHttpReq(rngStart As Excel.Range)  
                              
On Error GoTo TabelaHTML_Error  
 
Dim Request As Object  
Dim cookies As String  
Dim postParams As String
 
Const READYSTATE_COMPLETE = 4  
 
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")  
postParams = "utilizador=ma######&password=sk######"  
 
  With Request  
    'Debug.Print "----------------------------Pierwsze GET"  
    .Open "GET", "http://www.pmanager.org"  
    .Send  
    .WaitForResponse  
    'Debug.Print .getAllResponseHeaders()  
    'Debug.Print "----------------------------------------"  
 
 
 
 
 
 
 
 
 
 
    cookies = Split(Replace(Split(.getAllResponseHeaders(), vbCrLf)(6), "Set-Cookie: ", ""), ";")(0)  
 
    'Debug.Print "----------------------------POST - logowanie"  
    .Open "POST", "http://www.pmanager.org/default.asp?action=login"  
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
    .setRequestHeader "Content-Length", Len(postParams)  
    
 
    .setRequestHeader "Cookie", cookies  
    .Send postParams  
    .WaitForResponse  
      
    'Debug.Print .getAllResponseHeaders()  
    'Debug.Print "----------------------------------------"  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
    'Zapisz ThisWorkbook.Path & "\test.html", .responseText  
 
    Dim ii As Integer, NotR1 As Boolean  
    For ii = 1 To 3  
    
        .Open "GET", "http://www.pmanager.org/procurar.asp?action=proc_jog&nome=&pos=0&nacional=-1&" & _
                     "lado=-1&idd_op=%3C&idd=Wszystko&temp_op=%3C&temp=Wszystko&expe_op=%3E=&" & _
                     "expe=Wszystko&con_op=%3C&con=Wszystko&pro_op=%3E&pro=Wszystko&vel_op=%3E&" & _
                     "vel=Wszystko&forma_op=%3E&forma=Wszystko&cab_op=%3E&cab=Wszystko&ord_op=%3C=&" & _
                     "ord=Wszystko&cul_op=%3E&cul=Wszystko&pre_op=%3C=&pre=Wszystko&forca_op=%3E&" & _
                     "forca=Wszystko&lesionado=Wszystko&prog_op=%3E&prog=Wszystko&tack_op=%3E&" & _
                     "tack=Wszystko&internacional=Wszystko&passe_op=%3E&passe=Wszystko&pais=-1&rem_op=%3E&" & _
                     "rem=Wszystko&tec_op=%3E&tec=Wszystko&jmaos_op=%3E&jmaos=Wszystko&saidas_op=%3E&" & _
                     "saidas=Wszystko&reflexos_op=%3E&reflexos=Wszystko&agilidade_op=%3E&agilidade=Wszystko&" & _
                     "B1=Pesquisar&field=&pid=" & ii & "&sort=0&pv=1&qual_op=%3E&qual=Wszystko&talento=Wszystko"
        .setRequestHeader "Cookie", cookies
        .Send postParams  
        .WaitForResponse  
      
    '--------------zapis HTMLTable do tablicy tbl()  
        Dim htmlDocument As Object 'MSHTML.htmlDocument  
        Dim ieTables As Object, ieTable As Object 'MSHTML.HTMLTable  
        Dim ieRows As Object, ieRow As Object 'MSHTML.HTMLTableRow  
        Dim ieCells As Object, ieCell As Object 'MSHTML.HTMLTableCell  
        Dim tbl() As Variant, i As Long, j As Long  
          
        Set htmlDocument = CreateObject("HtmlFile")  
        With htmlDocument  
            'Zapisz ThisWorkbook.Path & "\test.html", Request.responseText  
            
 
            .body.innerHTML = Request.responseText  
              
            Set ieTables = .all.tags("TABLE")  
            Set ieTable = ieTables(0)  
            Set ieRows = ieTable.Rows  
            For Each ieRow In ieRows  
                i = i + 1  
                Set ieCells = ieRow.Cells  
                For Each ieCell In ieCells  
                    j = j + 1  
                    rngStart.Offset(i - 1, j - 1) = ieCell.innerText  
                    If NotR1 Then  
                        'If i > 1 Then  
                            If j = 2 Then  
                               With rngStart
                                   .Parent.Hyperlinks.Add Anchor:=.Offset(i - 1, j - 1), _
                                                          Address:="http://www.pmanager.org/" & _
                                                               Replace(ieCell.ChildNodes(0).ChildNodes(0).href, "about:", ""), _
                                                          TextToDisplay:=.Offset(i - 1, j - 1).Value
            
                               
                               End With
                            ElseIf j = 4 Then
                            
                                InsertPictureFromHTTP "http://www.pmanager.org/" & _
                                                      Replace(ieCell.ChildNodes(0).ChildNodes(0).ChildNodes(0).href, "about:", ""), _
                                                      rngStart.Offset(i - 1, j - 1)
                            
                              
                            End If  
                            'Stop  
                          
                        'End If  
                    End If  
                      
                Next  
                NotR1 = True  
                j = 0  
            Next  
 
        End With  
        'Stop  
        i = i + 1: j = 0: NotR1 = False  
    Next  
          
    '------------------------------------  
    
  End With
 
TabelaHTML_Exit:  
    On Error Resume Next  
              
    If Not Request Is Nothing Then  
        With Request  
            .Open "GET", "http://www.pmanager.org/logout.asp"  
            .setRequestHeader "Cookie", cookies  
            .Send  
            .WaitForResponse  
        End With  
    End If  
    Set Request = Nothing  
    Set htmlDocument = Nothing  
    Set ieTables = Nothing  
    Set ieRows = Nothing  
    Set ieCells = Nothing  
      
    Exit Sub  
              
TabelaHTML_Error:  
     MsgBox "Błąd Nr - " & Err.Number & vbCrLf & vbCrLf & _  
            Err.Description, vbExclamation, "VBAProject - TabelaHTMLvWinHttpReq"  
     Stop  
     Resume TabelaHTML_Exit  
    
 
End Sub  
 
Sub Zapisz(strFileName As String, strResponseText As String)  
    Dim nr As Integer: nr = VBA.FreeFile  
    Open strFileName For Output As #nr  
        Print #nr, strResponseText  
    Close #nr  
End Sub  
 
Function InsertPictureFromHTTP(strHTTP As String, Optional xlRng As Excel.Range)   Funkcja InsertPictureFromHTTP
    Dim xlShp As Excel.Shape  
    Dim rng As Excel.Range  
              
    If Not xlRng Is Nothing Then  
        Set rng = xlRng  
    Else  
        Set rng = Application.Caller.MergeArea  
    End If  
    With rng  
        On Error Resume Next  
        Set xlShp = .Parent.Shapes("kom" & .Address(external:=True))  
        If Not xlShp Is Nothing Then  
            Set xlShp = Nothing  
            Exit Function  
        End If  
        On Error GoTo 0  
                  
        Set xlShp = .Parent.Shapes.AddPicture(strHTTP, _  
                                              msoTrue, msoTrue, _  
                                              .Left, .Top, 16, 11) '.Width, .Height)  
        xlShp.Name = "kom" & .Address(external:=True)  
        Set xlShp = Nothing  
    End With  
    InsertPictureFromHTTP = vbNullString  
End Function  
 
a teraz chociaż w paru słowach "co i jak":  
 
    'Debug.Print "----------------------------Pierwsze GET"  
    .Open "GET", "http://www.pmanager.org"  
 
    cookies = Split(Replace(Split(.getAllResponseHeaders(), vbCrLf)(6), "Set-Cookie: ", ""), ";")(0)  
 
po wejściu na stronkę przeglądamy dane zwracane przez metodę .getAllResponseHeaders(). "Zmienna sesyjna" podawana jest we  
fragmencie "Set-Cookie:". Ten element zapisujemy do zmiennej cookies - będzie potrzeba zarówno do zalogowania jak i do realizacji  
zapytań do poszczególnych tabel z których będziemy importować dane.  
 
    'Debug.Print "----------------------------POST - logowanie"  
    .Open "POST", "http://www.pmanager.org/default.asp?action=login"  
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
    .setRequestHeader "Content-Length", Len(postParams)  
      
    .setRequestHeader "Cookie", cookies
 
    .Send postParams  
 
Wymagane nagłówki można podglądnąć analizując logowanie z włączonym FireBug'iem.   
 
    'Debug.Print .getAllResponseHeaders()  
 
Sprawdzam tu czy zmieniła się "zmienna sesyjna" po zalogowaniu. Gdyby tak było trzeba by wykorzystywać nową do importu   
danych. W tym przypadku do okna Immediate nie trafia informacja o nowej zmiennej a więc wykorzystujemy dotychczasową.  
 
    'Zapisz ThisWorkbook.Path & "\test.html", .responseText  
 
Sub Zapisz(strFileName As String, strResponseText As String)  
    Dim nr As Integer: nr = VBA.FreeFile  
    Open strFileName For Output As #nr  
        Print #nr, strResponseText  
    Close #nr  
End Sub  
 
to taki mój sposób na podglądnięcie czy wszystko poszło ok. :-) W procedurze wykorzystującej IE można by po prostu ieApp  
nadać wartość .Visible = True i zobaczyć jak wygląda przeglądarka z której importujemy dane. Tu nie ma takiej możliwości więc..  
.responseText zapisuję do tymczasowego pliku .html i sprawdzam jego zawartość włączając go w przeglądarce. Jeżeli udało się  
zalogować poprawnie to na pewno to zobaczę :-)  
 
        .Open "GET", "http://www.pmanager.org/procurar.asp?action=…  
        .setRequestHeader "Cookie", cookies  
        .Send postParams  
 
Następne zapytania GET z przekazaniem paramentów  
 
                    rngStart.Offset(i - 1, j - 1) = ieCell.innerText  
 
do komórek odpowiednio przesuniętych względem komórki początkowej zwracam tekst elementu tabeli HTML  
 
                            If j = 2 Then
                               With rngStart
                                   .Parent.Hyperlinks.Add Anchor:=.Offset(i - 1, j - 1), _
                                                          Address:="http://www.pmanager.org/" & _
                                                               Replace(ieCell.ChildNodes(0).ChildNodes(0).href, "about:", ""), _
                                                          TextToDisplay:=.Offset(i - 1, j - 1).Value
            
                               
                               End With
 
w kolumnie 2 tabeli HTML są hiperłącza. Odtworzymy je w docelowym arkuszu :-)  
 
                            ElseIf j = 4 Then
                            
                                InsertPictureFromHTTP "http://www.pmanager.org/" & _
                                                      Replace(ieCell.ChildNodes(0).ChildNodes(0).ChildNodes(0).href, "about:", ""), _
                                                      rngStart.Offset(i - 1, j - 1)
                            
                            
                            End If
 
w kolumnie 4 jest mała 16x11 flaga.  
W efekcie dostajemy tabelę podobną do tej :-)