VBA Internet suche

[losgehts]

Hallo,

ich glaube, ihr solltet besser die Methode GetElementsByTagName verwenden.

Meine HMTL-Kenntnisse sind rudimentär, doch span ist ein Tag und kein Name.

Rückgabewert ist bei beiden Methoden eine Collection.

Grüße, Ulrich

[Steffl]

Hallo Florian,

mir fällt nichts mehr dazu ein außer mit einer sicherlich nicht optimalen Fehlerbehandlung (außer Du vergleichst den Hypertext)

Code:

Private Sub XMLTEL()
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResult As Object, objrso As Object, Tel As Object
Dim i, str_text
lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
    Set html = CreateObject("htmlfile")
  
    For i = 2 To lastRow
        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & " " & Cells(i, 2) & " " & "Telefonnummer"
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.send

        html.body.innerHTML = XMLHTTP.ResponseText
        Set objResult = html.getElementByid("rso")
        On Error Resume Next
        Set objrso = objResult.getElementsByName("span")(0)   'Hier ist der Fehler!
        Set Tel = objrso.getElementsByName("span")(0)
        
        str_text = Replace(Tel.innerHTML, " ", "")
        Cells(i, 7) = "+49 " & str_text
        On Error GoTo 0
    DoEvents
    Next i
End Sub

[losgehts]

Hallo,

es geht doch um Fehler 92 (Objectvariable nicht festgelegt). Ich tippe darauf, dass die Variable objResult nothing ist.
Statt der OnError Resume Next Anweisung würde ich daher eine If-Abfrage formulieren:

Code:

if not objResult is nothing then

    ....

else
   debug.print html.body.innerHTML   ' zum analysieren warum objResult nothing ist
end if

Grüße, Ulrich

[edit: Tippfehler: ich meine Fehler 91]

[Steffl]

Hallo Ulrich,

Florian schreibt in diesem Thread aber immer vom Fehler 91.

[Florian20]

Hi nochmal,

Also das wusste Ich nicht das span kein Name sondern ein TagName ist.

Danke dafür schon mal Ich versuch mal mein Glück und melde mich wieder.

Lg Flo

[losgehts]

Hallo,

ich meinte auch Fehler 91, das war ein Tippfehler.

So ganz ohne Grund schreibe ich das ja auch nicht. Wenn ich den Code, den Steffl heute um 12.09 gepostet hat, teste dann erhalte ich ebenfalls die Fehlermeldung 91. Bei mir wehrt sich Google gegen die Abfrage und ich bekomme nicht die Seite ausgegeben, sondern eine Fehlermeldung als html-Seite ausgeliefert:

Code:

<A href="about://www.google.com/"><SPAN aria-label=Google id=logo></SPAN></A>
<P><B>403.</B> <INS>That’s an error.</INS>
<P>Your client does not have permission to get URL <CODE>/search?q=Sebastian%20Kasperski%20Telefonnummer</CODE> from this server. (Client IP address: **.**.**.**)<BR><BR>Please see Google's Terms of Service posted at http://www.google.com/terms_of_service.html <BR><BR>
<P>If you believe that you have received this response in error, please <A href="https://www.google.com/support/contact/user?hl=en">report</A> your problem. However, please make sure to take a look at our Terms of Service (http://www.google.com/terms_of_service.html).
[...]

Der obige HTML-Quelltext hat zur Folge, dass es kein Tag mit der ID "rso" gibt und damit die Methode getElementByid("rso") nothing zurückgibt.

Welche Suchbegriffe Florian an Google übermittelt und was er wiederum von Google geliefert bekommt, weiß ich (abgesehen von dem angehängten Bild) nicht.

Grüße, Ulrich

[Florian20]

Hallo,

Ja genau das ist auch das Problem bei mir
Also was Ich genau von Google will ist =   Autohaus Bumann GmbH Rostocker Str. 5 Telefonnummer
Also Firmen die Ich überprüfen will in Excel ob die Tel da ist wenn nicht dann aus Google Kopieren
In dem Bild wird die Tel angezeigt wo Sie in dem HTML code steht.

Lg Flo

Ps. Ich habe meine Cousine mal gefragt sie Ist Webpage Designerin mal schauen was Sie sagt

[Florian20]

Also meine Cousine hat mir geschrieben und eine Lösung gegeben doch geht diese auch nicht  

Hier mal Ihr weg vielleicht fällt jemanden auf das hier dann noch was ein


Private Sub xmlHTMLTel()
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
    Dim url As String, lastRow As Long
    Dim XMLHTTP As Object, html As Object, objResultDiv As Object, phone As Object, links As Object
   
lastRow = Range("A" & Rows.Count).End(xlUp).Row
   
For i = 2 To lastRow
        url = "https://www.google.co.in/search?q=" & Cells(i, 1) & Cells(i, 2) & " Telefonnummer" & WorksheetFunction.RandBetween(1, 10000)
       
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send
       
Set html = CreateObject("htmlfile")
        html.body.innerHTML = XMLHTTP.ResponseText
        Set links = html.getelementsbytagname("fl")
        Set phone = links(0).getAttribute("data-number") 'Hier ist der Fehler
  
        str_text = Replace(links.innerHTML, "", "")
        str_text = Replace(str_text, "", "")
        Cells(i, 7) = phone
       
DoEvents
    Next
End Sub

[losgehts]

Hallo,

sehr cool, dass deine Cousine weiß, wie man den Useragentstring anpassen kann.

Dieser Code funktioniert bei mir mit dem Suchbegriff
Autohaus Bumann GmbH Rostocker Str. 5 Telefonnummer

Code:

Private Sub xmlHTMLTel_test()
'Überprüft alle Neuen Firmen ob die Tel eingetragen wurde
    Dim url As String, lastRow As Long, i As Long
    Dim XMLHTTP As Object, html As Object
    Dim str_text As String
    
    Const strVorNr As String = "<DIV class=Z0LcW><SPAN data-local-attribute=""d3ph"" data-dtype=""d3ifr""><SPAN>"
    Const strNachNr As String = "</SPAN>"
  
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
  
    For i = 2 To lastRow
        url = "https://www.google.co.in/search?q=" & URLEncode(Cells(i, 1) & Cells(i, 2) & " Telefonnummer" & WorksheetFunction.RandBetween(1, 10000))
      
        Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
        XMLHTTP.Open "GET", url, False
        XMLHTTP.setRequestHeader "Content-Type", "text/xml"
        XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
        XMLHTTP.send
      
        Set html = CreateObject("htmlfile")
        html.body.innerhtml = XMLHTTP.ResponseText
        
        str_text = Mid(html.body.innerhtml, InStr(html.body.innerhtml, strVorNr) + Len(strVorNr))
        If InStr(str_text, strNachNr) > 0 Then    'nur um Fehler abzufangen
            str_text = Mid(str_text, 1, InStr(str_text, strNachNr) - 1)
        End If
        
'        Debug.Print str_text
        
        Cells(i, 7) = Trim(str_text)
        
        DoEvents        ' Wozu?
    Next
End Sub



Public Function URLEncode(strInput As String, Optional bBlankAsPlus As Boolean = False) As String
'Quelle: EtoPHG   http://www.office-loesung.de/ftopic486146_0_0_asc.php
    Dim lLen As Long: lLen = Len(strInput)
    If lLen > 0 Then
        ReDim strOutput(lLen) As String
        Dim lX As Long, iCode As Integer
        Dim strChar As String, strBlank As String
        If bBlankAsPlus Then strBlank = "+" Else strBlank = "%20"
        For lX = 1 To lLen
            strChar = Mid(strInput, lX, 1)
            iCode = Asc(strChar)
            Select Case iCode
                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    strOutput(lX) = strChar
                Case 32
                    strOutput(lX) = strBlank
                Case 0 To 15
                    strOutput(lX) = "%0" & Hex(iCode)
                Case Else
                    strOutput(lX) = "%" & Hex(iCode)
            End Select
        Next lX
        URLEncode = Join(strOutput, "")
    End If
End Function

Grüße, Ulrich

[Florian20]

Hallo und Guten Morgen,
Ich Danke euch allen es funktioniert jetzt Perfekt.
Lg Flo