it-swarm.dev

Analizza il contenuto HTML in VBA

Ho una domanda relativa all'analisi HTML. Ho un sito Web con alcuni prodotti e mi piacerebbe intercettare il testo all'interno di una pagina nel mio foglio di lavoro corrente. Questo foglio di calcolo è abbastanza grande ma contiene ItemNbr nella 3a colonna, mi aspetto che il testo nella quattordicesima colonna e una riga corrisponda a un prodotto (elemento).

La mia idea è di recuperare il "Materiale" sulla pagina web che si trova all'interno del testo dopo il tag. Il numero ID cambia da una pagina alla pagina (a volte).

Ecco la struttura del sito web:

<div style="position:relative;">
    <div></div>
    <table id="list-table" width="100%" tabindex="1" cellspacing="0" cellpadding="0" border="0" role="grid" aria-multiselectable="false" aria-labelledby="gbox_list-table" class="ui-jqgrid-btable" style="width: 930px;">
        <tbody>
            <tr class="jqgfirstrow" role="row" style="height:auto">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="1" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="2" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="3" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="4" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="5" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="6" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td ...</td>
                <td ...</td>
            </tr>
            <tr role="row" id="7" tabindex="-1" class="ui-widget-content jqgrow ui-row-ltr">
                <td role="gridcell" style="padding-left:10px" title="Material" aria-describedby="list-table_">Material</td>
                <td role="gridcell" style="" title="600D polyester." aria-describedby="list-table_">600D polyester.</td>
            </tr>           
            <tr ...>
            </tr>
        </tbody>
    </table> </div>

Mi piacerebbe ottenere "600D Polyester" come risultato.

Lo snippet di codice mio (non funzionante) è così com'è:

Sub ParseMaterial()

    Dim Cell As Integer
    Dim ItemNbr As String

    Dim AElement As Object
    Dim AElements As IHTMLElementCollection
Dim IE As MSXML2.XMLHTTP60
Set IE = New MSXML2.XMLHTTP60

Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLBody As MSHTML.HTMLBody

Set HTMLDoc = New MSHTML.HTMLDocument
Set HTMLBody = HTMLDoc.body

For Cell = 1 To 5                            'I iterate through the file row by row

    ItemNbr = Cells(Cell, 3).Value           'ItemNbr isin the 3rd Column of my spreadsheet

    IE.Open "GET", "http://www.example.com/?item=" & ItemNbr, False
    IE.send

    While IE.ReadyState <> 4
        DoEvents
    Wend

    HTMLBody.innerHTML = IE.responseText

    Set AElements = HTMLDoc.getElementById("list-table").getElementsByTagName("tr")
    For Each AElement In AElements
        If AElement.Title = "Material" Then
            Cells(Cell, 14) = AElement.nextNode.value     'I write the material in the 14th column
        End If
    Next AElement

        Application.Wait (Now + TimeValue("0:00:2"))

Next Cell

Grazie per l'aiuto !

10
Tdev

Solo un paio di cose che spero ti portino nella giusta direzione:

  • ripulire un po ': rimuovere il ciclo di test delle proprietà readystate. Il valore restituito dalla proprietà readystate non cambierà mai in questo contesto: il codice verrà messo in pausa dopo l'istruzione di invio, per riprendere solo una volta ricevuta la risposta del server o non è riuscito a farlo. La proprietà readystate verrà impostata di conseguenza e il codice riprenderà l'esecuzione. Dovresti ancora provare per lo stato pronto, ma il ciclo non è necessario

  • indirizzare gli elementi HTML corretti: stai cercando tra gli elementi tr - mentre la logica di come usi questi elementi nel tuo codice sembra effettivamente puntare a elementi td

  • assicurati che le proprietà siano effettivamente disponibili per gli oggetti su cui le stai usando: per aiutarti, prova e dichiara tutte le tue variabili come oggetti specifici invece dell'oggetto generico. Questo attiverà l'intellisense. Se hai difficoltà a trovare il nome effettivo del tuo oggetto come definito nella libreria pertinente in primo luogo, dichiaralo come oggetto generico, esegui il codice e poi ispeziona il tipo dell'oggetto - stampando typename (your_object) per esempio nella finestra di debug. Questo dovrebbe metterti sulla tua strada

Ho anche incluso del codice qui sotto che può aiutare. Se ancora non riesci a farlo funzionare e puoi condividere i tuoi URL, fallo.

Sub getInfoWeb()

    Dim cell As Integer
    Dim xhr As MSXML2.XMLHTTP60
    Dim doc As MSHTML.HTMLDocument
    Dim table As MSHTML.HTMLTable
    Dim tableCells As MSHTML.IHTMLElementCollection

    Set xhr = New MSXML2.XMLHTTP60

    For cell = 1 To 5

        ItemNbr = Cells(cell, 3).Value

        With xhr

            .Open "GET", "http://www.example.com/?item=" & ItemNbr, False
            .send

            If .readyState = 4 And .Status = 200 Then
                Set doc = New MSHTML.HTMLDocument
                doc.body.innerHTML = .responseText
            Else
                MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
                vbNewLine & "HTTP request status: " & .Status
            End If

        End With

        Set table = doc.getElementById("list-table")
        Set tableCells = table.getElementsByTagName("td")

        For Each tableCell In tableCells
            If tableCell.getAttribute("title") = "Material" Then
                Cells(cell, 14).Value = tableCell.NextSibling.innerHTML
            End If
        Next tableCell

    Next cell

End Sub

EDIT: come follow-up per le ulteriori informazioni fornite nel commento qui sotto - e i commenti aggiuntivi che ho aggiunto

'Determine your product number
    'Open an xhr for your source url, and retrieve the product number from there - search for the tag which
    'text include the "productnummer:" substring, and extract the product number from the outerstring
    'OR
    'if the product number consistently consists of the fctkeywords you are entering in your source url
    'with two "0" appended - just build the product number like that
'Open an new xhr for this url "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2productspec-ajax.p?itemc=" & product_number & "&_search=false&rows=-1&page=1&sidx=&sord=asc"
'Load the response in an XML document, and retrieve the material information

Sub getInfoWeb()

    Dim xhr As MSXML2.XMLHTTP60
    Dim doc As MSXML2.DOMDocument60
    Dim xmlCell As MSXML2.IXMLDOMElement
    Dim xmlCells As MSXML2.IXMLDOMNodeList
    Dim materialValueElement As MSXML2.IXMLDOMElement

    Set xhr = New MSXML2.XMLHTTP60

        With xhr

            .Open "GET", "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2productspec-ajax.p?itemc=10031700&_search=false&rows=-1&page=1&sidx=&sord=asc", False
            .send

            If .readyState = 4 And .Status = 200 Then
                Set doc = New MSXML2.DOMDocument60
                doc.LoadXML .responseText
            Else
                MsgBox "Error" & vbNewLine & "Ready state: " & .readyState & _
                vbNewLine & "HTTP request status: " & .Status
            End If

        End With

        Set xmlCells = doc.getElementsByTagName("cell")

        For Each xmlCell In xmlCells
            If xmlCell.Text = "Materiaal" Then
                Set materialValueElement = xmlCell.NextSibling
            End If
        Next

        MsgBox materialValueElement.Text

End Sub

EDIT2: un'alternativa che automatizza IE

Sub searchWebViaIE()
    Dim ie As SHDocVw.InternetExplorer
    Dim doc As MSHTML.HTMLDocument
    Dim anchors As MSHTML.IHTMLElementCollection
    Dim anchor As MSHTML.HTMLAnchorElement
    Dim prodSpec As MSHTML.HTMLAnchorElement
    Dim tableCells As MSHTML.IHTMLElementCollection
    Dim materialValueElement As MSHTML.HTMLTableCell
    Dim tableCell As MSHTML.HTMLTableCell

    Set ie = New SHDocVw.InternetExplorer

    With ie
        .navigate "http://www.pfconcept.com/cgi-bin/wspd_pcdb_cgi.sh/y/y2facetmain.p?fctkeywords=100317&world=general#tabs-4"
        .Visible = True

        Do While .readyState <> READYSTATE_COMPLETE Or .Busy = True
            DoEvents
        Loop

        Set doc = .document

        Set anchors = doc.getElementsByTagName("a")

        For Each anchor In anchors
            If InStr(anchor.innerHTML, "Product Specificatie") <> 0 Then
                anchor.Click
                Exit For
            End If
        Next anchor

        Do While .readyState <> READYSTATE_COMPLETE Or .Busy = True
            DoEvents
        Loop

    End With

    For Each anchor In anchors
        If InStr(anchor.innerHTML, "Product Specificatie") <> 0 Then
            Set prodSpec = anchor
        End If
    Next anchor

    Set tableCells = doc.getElementById("list-table").getElementsByTagName("td")

    If Not tableCells Is Nothing Then
        For Each tableCell In tableCells
            If tableCell.innerHTML = "Materiaal" Then
                Set materialValueElement = tableCell.NextSibling
            End If
        Next tableCell
    End If

    MsgBox materialValueElement.innerHTML

End Sub
9
IAmDranged

Non correlato a tabelle o Excel (utilizzo MS-Access 2013) ma direttamente correlato al titolo dell'argomento. La mia soluzione è 

Private Sub Sample(urlSource)
Dim httpRequest As New WinHttpRequest
Dim doc As MSHTML.HTMLDocument
Dim tags As MSHTML.IHTMLElementCollection
Dim tag As MSHTML.HTMLHtmlElement
httpRequest.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible;MSIE 7.0; Windows NT 6.0)"
httpRequest.Open "GET", urlSource
httpRequest.send ' fetching webpage
Set doc = New MSHTML.HTMLDocument
doc.body.innerHTML = httpRequest.responseText
Set tags = doc.getElementsByTagName("a")
i = 1
For Each tag In tags
  Debug.Print i
  Debug.Print tag.href
  Debug.Print tag.innerText
  'Debug.Print tag.Attributes("any other attributes you need")() ' may return an object
  i = i + 1
  If i Mod 50 = 0 Then Stop
  ' or code to store results in a table
Next
End Sub
0
Jean-Marc