VBA Web слом из www.eppraisal.com

Question

Мне нужно получить данные из www.eppraisal.com

Так я написал следующий код, но он не работает, к сожалению:

Public Function GetEppraisalValuation() 
    Dim strURL As String 
    Dim strLocationURL As String 

    Dim strEppraisalValue As String 
    Dim strEppraisalHighLow As String 

    Dim lngStartPointer As Long 
    Dim lngEndPointer As Long 

    'strAddressForWeb1 = "4189 E LAFAYETTE AVE" 
    'strAddressForWeb2 = "GILBERT, AZ 85298" 
    strURL = "http://www.eppraisal.com/home-values/property/1122-e-loyola-dr-tempe-az-85282-42382460/" 

    Set zHttp = CreateObject("WinHttp.WinHttpRequest.5.1") 
    zHttp.Open "GET", strURL, False 
    zHttp.Option(iWinHttpRequestOption_EnableRedirects) = False 
    zHttp.setRequestHeader "Accept", "text/html, application/xhtml+xml, */*" 
    zHttp.setRequestHeader "Accept-Encoding", "gzip, deflate" 
    zHttp.setRequestHeader "Accept-Language", "en-us" 
    zHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; Trident/5.0)" 
    zHttp.setRequestHeader "Referer", strURL 
    zHttp.setRequestHeader "Connection", "Keep-Alive" 
    zHttp.setRequestHeader "Host", "www.eppraisal.com" 
    'zHttp.setRequestHeader "Cookie", "ASP.NET_SessionId=" & SessionID 
    'zHttp.setRequestHeader "Cookie", ".ASPXAUTH=" & ASPXAUTH 

    zHttp.send 

    If zHttp.Status <> 302 Then 
     Exit Function 
    End If 

    strLocationURL = zHttp.getResponseHeader("Location") 

    strURL = "http://www.eppraisal.com" & strLocationURL 
    'DeleteUrlCacheEntry (strURL) 

    zHttp.Open "GET", strURL, False 
    zHttp.Option(iWinHttpRequestOption_EnableRedirects) = True 
    zHttp.setRequestHeader "Accept", "text/html, application/xhtml+xml, */*" 
    'zHttp.setRequestHeader "Accept-Encoding", "gzip, deflate" 
    zHttp.setRequestHeader "Accept-Language", "en-us" 
    zHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; Trident/5.0)" 
    zHttp.setRequestHeader "Referer", strURL 
    zHttp.setRequestHeader "Connection", "Keep-Alive" 
    zHttp.setRequestHeader "Host", "www.eppraisal.com" 
    'zHttp.setRequestHeader "Cookie", "ASP.NET_SessionId=" & SessionID 
    'zHttp.setRequestHeader "Cookie", ".ASPXAUTH=" & ASPXAUTH 

    zHttp.send 

    If zHttp.Status <> 200 Then 
     Exit Function 
    End If 

    ieDom.body.innerHTML = zHttp.responseText 
    For Each ieInp In ieDom.getElementsByTagName("p") 
     If ieInp.className = "ColorAccent6 FloatLeft FontSizeK Margin0" Then 
      strEppraisalValue = ieInp.innerText 
      Exit For 
     End If 
    Next 

    For Each ieInp In ieDom.getElementsByTagName("p") 
     If ieInp.className = "FontSizeA FloatRight Margin0 DisplayNone HighLow" Then 
      strEppraisalHighLow = ieInp.innerText 
      Exit For 
     End If 
    Next 

    wrkshtPI.Range("C1").Offset(intRowOffset, 0) = strEppraisalValue 

    lngStartPointer = InStr(1, strEppraisalHighLow, "Low:") 
    If lngStartPointer = 0 Then 
     Exit Function 
    End If 
    lngEndPointer = InStr(1, strEppraisalHighLow, Chr(10)) 
    If lngEndPointer = 0 Then 
     Exit Function 
    End If 
    wrkshtPI.Range("D1").Offset(intRowOffset, 0) = Trim(Mid(strEppraisalHighLow, lngStartPointer + 4, lngEndPointer - (lngStartPointer + 5))) 
    wrkshtPI.Range("E1").Offset(intRowOffset, 0) = Trim(Mid(strEppraisalHighLow, lngEndPointer + 7, Len(strEppraisalHighLow) - (lngEndPointer + 7))) 
End Function 

код состояния zHTTP не подходит как 302, что недопустимо. Также я получаю некоторые значения нежелательной почты в ResponseBody.

Я выделил 3 фигуры, которые я хочу получить ниже на снимке экрана.

Не могли бы вы предложить, что именно происходит неправильно?

Спасибо.

Answer 1

Здесь вы идете

Const URl As String = "http://www.eppraisal.com/home-values/property_lookup_eppraisal?a=1122%20E%20Loyola%20Dr&z=85282&propid=42382460" 
Sub xmlHttp() 
    Dim xmlHttp As Object 
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP") 
    xmlHttp.Open "GET", URl, False 
    xmlHttp.setRequestHeader "Content-Type", "text/xml" 
    xmlHttp.send 


    Dim html As Object 
    Set html = CreateObject("htmlfile") 
    html.body.innerHTML = xmlHttp.ResponseText 
    Debug.Print html.body.innerHTML 
End Sub 

Выход на открывшееся окно

<P style="LINE-HEIGHT: 1.2em" class="ColorAccent6 FontBold FontSizeM Margin0 Padding0">$148,305</P> 
<P style="LINE-HEIGHT: 1.1em" class="FontSizeA Margin0 DisplayNone HighLow">Low: $126,059 <BR>High: $170,550</P> 

Answer 2

у меня была аналогичная проблема, пока я не обнаружил, что сервер ответил содержание GZIP, потому что я также установите «Accept-Encoding», «gzip, deflate».

Я изменил заголовки запроса на: SetRequestHeader («Accept», «text/html; charset = UTF-8»); SetRequestHeader («Accept-Encoding», «identity»); SetRequestHeader («Accept-Charset», «UTF-8»); , а затем сервер ответил текстом в Юникоде.

Надеюсь, это поможет ... Майкл