Fritzboxdingsbums, Rückwärtssuche über www.telsearch.ch für Outlook

Function RWStelsearch(ByRef TelNr As String, ByRef vCard As String) As Boolean
    ' führt die Rückwärtssuche über 'www.telsearch.ch' durch
    ' Parameter:  TelNr (String):  Telefonnummer des zu Suchenden
    '             vCard (String):  vCard falls was gefunden wurde (nur Rückgabewert)
    ' Rückgabewert (Boolean):      'true' wenn was gefunden wurde

    Dim myurl                            As String             ' URL von telsearch
    Dim temp                             As String             ' Hilfsstring
    Dim tempTelNr                        As String             ' Hilfsstring für TelNr
    Dim alleTelNr                        As String             ' alle TelNr der gefundenen vCard
    Dim http                             As New WinHttpRequest ' WinHttp-Objekt
    Dim htmltelsearch                        As String             ' Inhalt der Webseite
    Dim Vorwahl                          As String             ' Vorwahl von TelNr
    Dim pos1 As Long, pos2 As Long, pos3 As Long               ' Positionen in 'htmltelsearch'
    Dim i                                As Long               ' Zählvariable
    
    'Eindeutige Suchwörter, nach denen die gesuchten Daten anfangen (ohne ", chr(09), chr(10) und chr(13)):
    Const SWVisitenkarte1 As String = "<a href=/vCard/"
    Const SWVisitenkarte2 As String = "title"
    
    ' TelNr sichern, da sie unter Umständen verändert wird
    tempTelNr = nurZiffern(TelNr, "0041")
    ' Suche wird unter Umständen mehrfach durchgeführt, da auch Firmennummern gefunden werden sollen.
    ' Dafür werden die letzten beiden Ziffern von TelNr durch '0' ersetzt und noch einmal gesucht.
    ' Schleife wird maximall drei mal durchlaufen
    i = 0
    Do
        ' Webseite für Rückwärtssuche aufrufen und herunterladen
        myurl = "http://tel.search.ch/result.html?name=&misc=&strasse=&ort=&kanton=&tel=" & tempTelNr
        http.Open "GET", myurl, True
        On Error GoTo catch
        http.send
        If http.WaitForResponse(10) Then
            htmltelsearch = Replace(http.ResponseText, Chr(34), "", , , vbTextCompare) '" enfernen
        Else
            htmltelsearch = ""
        End If
        On Error GoTo 0
        ' Link zum Herunterladen der vCard suchen
        pos1 = InStr(1, htmltelsearch, SWVisitenkarte1, vbTextCompare)
        If Not pos1 = 0 Then
            pos2 = InStr(pos1, htmltelsearch, SWVisitenkarte2, vbTextCompare)
            If Not pos1 = Len(SWVisitenkarte2) And Not pos2 = 0 Then
                ' vCard herunterladen
                myurl = "http://tel.search.ch/" & Mid(htmltelsearch, pos1 + 9, pos2 - pos1 - 10)
                myurl = Replace(myurl, "html", "vcf")
                http.Open "GET", myurl, True
                On Error GoTo catch
                http.send
                If http.WaitForResponse(10) Then vCard = http.ResponseText Else vCard = ""
                On Error GoTo 0
                ' formatierte Telefonnummer aus vCard entnehmen
                alleTelNr = ReadFromVCard(vCard, "TEL", "")
                Do
                    pos1 = InStr(1, alleTelNr, ";", vbTextCompare)
                    If pos1 = 0 Then temp = alleTelNr Else temp = Left(alleTelNr, pos1 - 1)
                    Vorwahl = OrtsVW(temp)
                    alleTelNr = Mid(alleTelNr, pos1 + 1)
                Loop Until pos1 = 0 Or Not InStr(1, TelNr, Vorwahl, vbTextCompare) = 0
                TelNr = formatTelNr(TelNr, Vorwahl, "0041", False)
            End If
        End If
        ' Rückgabewert ermitteln
        RWStelsearch = Left(vCard, 11) = "BEGIN:VCARD"
        i = i + 1
        tempTelNr = Left(tempTelNr, Len(tempTelNr) - 2) & 0
    Loop Until RWStelsearch Or i = 3
    ' Besonderheit bei 'telsearch': Vor- und Nachname sind in vCard separat angegeben
    ' wenn kein Vorname vorhanden ist, dann "muss" es sich um eine Firma handeln
    ' dann wird der volle Name in der vCard (FN) in den Firmennamen (ORG) übertragen
    If RWStelsearch Then
        If InStr(1, ReadFromVCard(vCard, "N", ""), ";;;;", vbTextCompare) Then
            vCard = Replace(vCard, Chr(10) & "FN:", Chr(10) & "ORG:", , , vbTextCompare)
        End If
    End If
Exit Function
catch:
    MsgBox "Fehler: " & Err.Description, vbCritical, "Fehler"
End Function

    ' Einstellungen für die Rückwärtssuche laden
    Me.ComboBoxRWS.AddItem ("DasÖrtliche")
    Me.ComboBoxRWS.AddItem ("GoYellow.de")
    Me.ComboBoxRWS.AddItem ("11880.com")
    Me.ComboBoxRWS.AddItem ("telsearch")
    Me.ComboBoxRWS.ListIndex = GetSetting("FritzBox", "Optionen", "CBoxRWSuche", 0)