Przykład importu danych ze stron internetowych za pomocą obiektów:
MSXML2.xmlHTTP ; MSXML.DOMDocument ; HtmlFile i WinHttp.WinHttpRequest
  strona główna:
A po co ten Excel ;-)
 
 
 
 
 
    Tematyka dla mnie nowa i chciałbym gdzieś zapisać sobie "co i jak" bo nie wiadomo kiedy trafi się   
następna okazja wykorzystania tych narzędzi a poznane metody żal byłoby utracić - pamięć nieużywana  
bywa zawodna ;-)  
 
Zadanie polega na imporcie danych ze strony internetowej:  
http://www.mpmoil.nl/products/recommendation.php  
dane ze stronki pobiera się poprzez dokonywanie kolejnych wyborów spośród bloków danych na 4'rech  
etapach.
 
 
 
 
 
 
W bloku pierwszym podaje się kategorię główną (id) lista jest w źródle strony.  
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Napiszemy UserForm na którym będą 4'ry ComboBoxy których kolejno dokonywane wybory będą uzupełniać kontrolki: z kolejnych bloków  
danych oraz informacje nt dokonanego wyboru: tj.
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
Jak wypełnić pierwsze Combo (nazwane Block1):  
 
Private Sub UserForm_Initialize()  
    Dim htmlDocument As MSHTML.htmlDocument  
    Dim el As MSHTML.HTMLElementCollection  
    Dim request As WinHttp.WinHttpRequest  
      
    Dim i As Integer  
 
    Set htmlDocument = New MSHTML.htmlDocument ' CreateObject("HtmlFile")  
    Set request = New WinHttp.WinHttpRequest  ' CreateObject("WinHttp.WinHttpRequest.5.1")  
 
    With request  
        .Open "GET", "http://www.mpmoil.nl/products/recommendation.php", True  
        .send  
        .waitForResponse  
        htmlDocument.body.innerHTML = .responseText  
    End With  
      
    With Me.Block1  
        .Clear  
        For Each el In htmlDocument.GetElementByID("block1").getElementsByTagName("a")  
            .AddItem i  
            .List(.ListCount - 1, 0) = el.id  
            .List(.ListCount - 1, 1) = el.innerText  
        Next  
    End With  
 
      
    Set el = Nothing  
    Set htmlDocument = Nothing  
    Set request = Nothing  
End Sub   Firebug
Firebug dodaje do Firefoksa bogactwo narzędzi programistycznych. Można edytować, analizować kod oraz monitorować CSS, HTML i JavaScript bezpośrednio na dowolnej stronie internetowej…
 
Jak drugie Combo, trzecie i czwarte (Block2, Block3, Block4)  
… najpierw dwa słowa wstępu. Sporym ułatwieniem sprawy jest posiadanie FireBug'a  
dodatek uruchamiamy F12 i przechodzimy na zakładkę Sieć  
Po kliknięciu na np.: Klassieke auto's
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
na liście FireBug'a pokazuje się wywołana kliknięciuem akcja:  
 
 
 
 
 
 
 
 
 
 
 
na stronkę: http://www.mpmoil.nl/products/recommendation.ajax.2.php  
wysyłane zostaje, metodą POST zapytanie z parametrami ids=_32  
a w odpowiedzi otrzymujemy:
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
xml :-) a w nim przy kolejnych id numery które potrzebujemy do Wypełnienia Combo2 (Block2)  
Jak więc pobrać te dane do Block2 (oraz następnych: Block3 i Block4) ??  
 
 
Private Sub Block1_Change()  
    With Me  
        .Block2.Clear  
        .Block3.Clear  
        .Block4.Clear  
        .info.Caption = ""  
    End With  
      
    Dim msXML As MSXML2.XMLHTTP  
    Dim msDoc As MSXML2.DOMDocument  
    Dim colNodes As Object  
    Dim oNode As Object  
    Const READYSTATE_COMPLETE = 4  
      
    Dim i As Long, j As Long  
      
    With Me.Block1  
        If .ListIndex = -1 Then Exit Sub  
        Dim params As String: params = "ids=" & .List(.ListIndex, 0)  
    End With  
 
    Const xPAth As String = "//recommendation/blocks/block2"  
                                   
    Set msXML = New MSXML2.XMLHTTP ' CreateObject("MSXML2.xmlHTTP")  
    Set msDoc = New MSXML2.DOMDocument ' CreateObject("MSXML.DOMDocument")  
      
    With msXML  
        .Open "POST", "http://www.mpmoil.nl/products/recommendation.ajax.2.php"  
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
        .send params  
        Do: DoEvents: Loop Until .readyState = READYSTATE_COMPLETE  
    End With  
 
    With msDoc  
        .LoadXML msXML.responseText  
        Set colNodes = .DocumentElement.SelectSingleNode(xPAth).ChildNodes  
        With Me.Block2  
            .Clear  
            For i = 1 To colNodes.Length - 1  
 
                'For j = 0 To 3  
                '    With colNodes(i).ChildNodes(j)  
                '        Debug.Print .tagName & ": " & .nodeTypedValue  
                '    End With  
                'Next  
 
                .AddItem j  
                .List(.ListCount - 1, 0) = colNodes(i).ChildNodes(3).nodeTypedValue  
                .List(.ListCount - 1, 1) = colNodes(i).ChildNodes(0).nodeTypedValue  
            Next  
        End With  
    End With  
 
    Set colNodes = Nothing  
    Set msXML = Nothing  
    Set msDoc = Nothing  
End Sub  
 
Private Sub Block2_Change()  
    With Me  
        .Block3.Clear  
        .Block4.Clear  
        .info.Caption = ""  
    End With  
      
    Dim msXML As MSXML2.XMLHTTP  
    Dim msDoc As MSXML2.DOMDocument  
    Dim colNodes As Object  
    Dim oNode As Object  
    Const READYSTATE_COMPLETE = 4  
      
    Dim i As Long, j As Byte  
      
    With Me.Block2  
        If .ListIndex = -1 Then Exit Sub  
        Dim params As String: params = "ids=" & .List(.ListIndex, 0)  
    End With  
      
    Const xPAth As String = "//recommendation/blocks/block3/item"  
                                                   
    Set msXML = New MSXML2.XMLHTTP ' CreateObject("MSXML2.xmlHTTP")  
    Set msDoc = New MSXML2.DOMDocument ' CreateObject("MSXML.DOMDocument")  
      
    With msXML  
        .Open "POST", "http://www.mpmoil.nl/products/recommendation.ajax.2.php"  
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
        .send params  
        Do: DoEvents: Loop Until .readyState = READYSTATE_COMPLETE  
    End With  
      
    With msDoc  
        .LoadXML msXML.responseText  
        Set colNodes = .DocumentElement.SelectNodes(xPAth)  
          
        With Me.Block3  
            .Clear  
            For Each oNode In colNodes  
                   
                'For j = 0 To 4  
                '    With oNode.ChildNodes(j)  
                '        Debug.Print .tagName & ": " & .nodeTypedValue  
                '    End With  
                'Next  
                  
                .AddItem j  
                .List(.ListCount - 1, 0) = oNode.ChildNodes(4).nodeTypedValue  
                .List(.ListCount - 1, 1) = oNode.ChildNodes(0).nodeTypedValue  
      
            Next  
        End With  
    End With  
    Set oNode = Nothing  
    Set colNodes = Nothing  
    Set msXML = Nothing  
    Set msDoc = Nothing  
      
End Sub  
 
Private Sub Block3_Change()  
    With Me  
        .Block4.Clear  
        .info.Caption = ""  
    End With  
    
    Dim msXML As MSXML2.XMLHTTP  
    Dim msDoc As MSXML2.DOMDocument  
    Dim colNodes As Object  
    Dim oNode As Object  
    Const READYSTATE_COMPLETE = 4  
      
    Dim i As Long, j As Byte  
 
    With Me.Block3  
        If .ListIndex = -1 Then Exit Sub  
        Dim params As String: params = "ids=" & .List(.ListIndex, 0)  
    End With  
      
    Const xPAth As String = "//recommendation/blocks/block4/item"  
                                                   
    Set msXML = New MSXML2.XMLHTTP ' CreateObject("MSXML2.xmlHTTP")  
    Set msDoc = New MSXML2.DOMDocument ' CreateObject("MSXML.DOMDocument")  
      
    With msXML  
        .Open "POST", "http://www.mpmoil.nl/products/recommendation.ajax.2.php"  
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
        .send params  
        Do: DoEvents: Loop Until .readyState = READYSTATE_COMPLETE  
    End With  
      
    With msDoc  
        .LoadXML msXML.responseText  
        Set colNodes = .DocumentElement.SelectNodes(xPAth)  
          
        With Me.Block4  
            .Clear  
            For Each oNode In colNodes  
                   
                'For j = 0 To 4  
                '    With oNode.ChildNodes(j)  
                '        Debug.Print .tagName & ": " & .nodeTypedValue  
                '    End With  
                'Next  
                  
                .AddItem j  
                .List(.ListCount - 1, 0) = oNode.ChildNodes(6).nodeTypedValue  
                .List(.ListCount - 1, 1) = oNode.ChildNodes(0).nodeTypedValue  
      
            Next  
        End With  
    End With  
    Set oNode = Nothing  
    Set colNodes = Nothing  
    Set msXML = Nothing  
    Set msDoc = Nothing  
End Sub  
 
I wypełnienie labela Info:  
 
 
Private Sub Block4_Change()  
    Dim msXML As MSXML2.XMLHTTP  
    Dim msDoc As MSHTML.htmlDocument  
 
    Const READYSTATE_COMPLETE = 4  
      
    With Me.Block4  
        If .ListIndex = -1 Then Exit Sub  
        Dim params As String: params = "ids=" & .List(.ListIndex, 0)  
    End With  
                                      
    Set msXML = New MSXML2.XMLHTTP ' CreateObject("MSXML2.xmlHTTP")  
    Set msDoc = New MSHTML.htmlDocument ' CreateObject("MSXML.DOMDocument")  
      
    With msXML  
        .Open "POST", "http://www.mpmoil.nl/products/recommendation.ajax.2.php"  
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"  
        .send params  
        Do: DoEvents: Loop Until .readyState = READYSTATE_COMPLETE  
    End With  
      
    With msDoc  
        .body.innerHTML = msXML.responseText  
        Me.info.Caption = .GetElementByID("olyslager").innerText  
    End With  
 
    Set msXML = Nothing   Przykład do pobrania:
    Set msDoc = Nothing   xmlhttp.zip
 
End Sub  
 
Ten przykład pewnie nikomu się nie przyda ale nie o to chodzi :-) Taki sposób importy danych ze stron internetowych jest wg mnie   
całkiem ciekawy a metody i wykorzystywane narzędzia godne zapamiętania. Nie jest to jakiś uniwersalny sposób. Każda strona może  
być inaczej skonstruowana. Ważne jest wykorzystanie FireBug'a do przeglądania ruchu w Sieci i wykorzystanie tych informacji do  
stworzenia zapytania oraz dobór obiektów i metod do interpretacji odpowiedzi ze strony. Dla mnie super sprawa ;-)